[Common Lisp] Common Lisp で DI コンテナ

仕事で Java の DI コンテナ（Seasar と Spring）を調べています。
DI って悪くない、と思いました。
ということで、ちょっと Common Lisp でも DI をやってみようかと思います。
Java の DI では定義ファイルは XML ですが、Common Lisp ならやはり S 式です。
S 式なら Seasar の定義ファイルの components, component タグ相当をマクロにしてしまえば、S2ContainerFactory.create("app.dicon") は (load "app") とロードするだけでおしまいになります。
簡単な DI コンテナの機能なら、DI コンテナを実装するというより、定義ファイル用のマクロを実装するだけになります。
また 定義ファイル = ソースコード となるのでコンパイルしておくこともできます。
こういうときはマクロは最高です。
とりあえず、コンストラクタインジェクションと、セッターインジェクションのかわりのスロットインジェクションを実装してみました。
自動バインディング等はなし、コンポーネントの取得は name による取得のみです。

DI コンテナの実装、というよりもむしろ定義ファイルのマクロの実装: di.lisp

(defpackage :di
  (:use :cl)
  (:export :components
           :component
           :ref
           :get-component))

(in-package :di)

(defvar *components* (make-hash-table)
  "生成したコンポーネントを登録しておくテーブル。")

(defmacro components (&body body)
  "上から順番にインスタンスを生成し、最後にまとめてスロットインジェクションを行う。"
  `(dolist (f (list ,@body))
     (when f (funcall f))))

(defmacro component (&key class (name class) initargs slots
                     (instance :singleton))
  "make-instance でインスタンスを作成して *components* に登録する。
slot への値設定は他のオブジェクトの参照を含んでいても大丈夫なように lambda でくるんで返し、
後で実行する。"
  (let ((self (gensym)))
    (if (eq instance :singleton)
        `(let ((,self (setf (gethash ',name *components*)
                            (make-instance ',class ,@initargs))))
           #'(lambda ()
               ,@(loop for (name value) on slots by #'cddr
                    collect `(setf (slot-value ,self ',name) ,value))
               ,self))
        `(progn (setf (gethash ',name *components*)
                      #'(lambda ()
                          (let ((,self (make-instance ',class ,@initargs)))
                            ,@(loop for (name value) on slots by #'cddr
                                 collect `(setf (slot-value ,self ',name)
                                                ,value))
                            ,self)))
                nil))))

(defmacro ref (name)
  "他のインスタンスの参照。"
  `(let ((object-or-function (gethash ,name *components*)))
     (typecase object-or-function
       (function (funcall object-or-function))
       (t object-or-function))))

(defun get-component (name)
  "name での取得のみサポート"
  (ref name))

サンプル定義ファイル: app.lisp

(in-package :di-test)

(components
 (component :name :f1 :class foo)
 (component :name :f2 :class foo :initargs (:foo-slot1 "Hello" :foo-slot2 2))
 (component :name :b1 :class bar :initargs (:bar-slot1 "ばあ" :bar-slot2 8))
 (component :name :f3 :class foo :initargs (:foo-slot1 (ref :b1)))
 (component :name :f4 :class foo
            :slots (foo-slot1 "まみむめも"
                    foo-slot2 (ref :b2)))
 (component :name :b2 :class bar
            :slots (bar-slot1 "ばあ2" bar-slot2 2))
 (component :name :f5 :class foo :instance :prototype
            :slots (foo-slot1 :prototype foo-slot2 :singleton))
 )

テストコード: di-test.lisp

(defpackage :di-test
  (:use :cl :di))

(in-package :di-test)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :ptester))

(defclass foo ()
  ((foo-slot1 :accessor foo-slot1 :initarg :foo-slot1)
   (foo-slot2 :accessor foo-slot2 :initarg :foo-slot2)))

(defclass bar ()
  ((bar-slot1 :accessor bar-slot1 :initarg :bar-slot1)
   (bar-slot2 :accessor bar-slot2 :initarg :bar-slot2)))


;; components, component はマクロになっているのでロードしてしまう。
(load "app")

(ptester:with-tests ()
  ;; 単純なオブジェクト生成。
  (let ((f1 (get-component :f1)))
    (ptester:test nil (null f1)))
  ;; コンストラクタインジェクション。
  (let ((f2 (get-component :f2)))
    (ptester:test "Hello" (foo-slot1 f2) :test #'string=)
    (ptester:test 2 (foo-slot2 f2)))
  ;; 他のオブジェクトを引数にしたコンストラクタインジェクション。
  (let ((f3 (get-component :f3)))
    (ptester:test "ばあ" (bar-slot1 (foo-slot1 f3)) :test #'string=))
  ;; プロパティインジェクションではなくスロットインジェクション。
  (let ((f4 (get-component :f4)))
    (ptester:test "まみむめも" (foo-slot1 f4) :test #'string=)
    (ptester:test "ばあ2" (bar-slot1 (foo-slot2 f4)) :test #'string=))
  ;; instance のテスト
  (let ((f1 (get-component :f1))
        (f2 (get-component :f1))
        (f3 (get-component :f5))
        (f4 (get-component :f5)))
    (ptester:test t (eq f1 f2))
    (ptester:test nil (eq f3 f4))
    (ptester:test :prototype (foo-slot1 f3))
    (ptester:test :singleton (foo-slot2 f4)))
  )

Common Lisp のマクロって素敵じゃありませんか？