[CommonLisp]MOPを使って型指定子によりメソッドを特定する

Wikipedia日本語版の「列挙型」の項目に、CommonLispの型指定子はメソッドの引数特定には使えませんよ、と書いてあったので、無理やり実現する方法を考えてみました。
マクロを使うと負けな気がするので、MOPを利用してみます。

(asdf:load-system :closer-mop)

(defpackage type-spec-class
  (:use :cl)
  (:export
    <type-spec-meta>
    <type-spec-gf>
    define-type-spec))

(in-package :type-spec-class)

(defclass <type-spec-meta> (c2mop:standard-class)
  ((spec :initarg :spec :reader type-spec-of)))

(defmethod c2mop:validate-superclass ((cls <type-spec-meta>)
          (super c2mop:standard-class))
  t)

(defclass <type-spec-gf> (c2mop:standard-generic-function)
  ()
  (:metaclass c2mop:funcallable-standard-class))

(defmethod c2mop:validate-superclass ((cls <type-spec-gf>)
          (super c2mop:standard-generic-function))
  t)

(defmacro define-type-spec (name spec)
  `(progn
     (deftype ,name () ,spec)
     (c2mop:ensure-class-using-class
      (make-instance '<type-spec-meta> :spec ,spec)
      ',name)))

(defmethod c2mop:compute-discriminating-function :around
    ((gf <type-spec-gf>))
  (let ((org-fn (call-next-method)))
    (lambda (&rest args)
      (let* ((methods (c2mop:generic-function-methods gf))
             (m (find-type-spec-method methods args)))
       (if m
         (apply (c2mop:method-function m) args)
         (apply org-fn args))))))

(defun find-type-spec-method (methods args)
  (loop
     :for m in methods
     :for s = (c2mop:method-specializers m)
     :do (when (applicable-type-spec-method-p s args)
           (return-from find-type-spec-method m))))

(defun applicable-type-spec-method-p (specifier args)
  (flet ((type-spec-class-p (cls)
    (subtypep (class-of cls) '<type-spec-meta>)))
    (when (some #'type-spec-class-p specifier)
      (loop
        :for cls in specifier
        :for a in args
        :do (unless (or (and (type-spec-class-p cls)
                             (typep a (type-spec-of cls)))
                        (typep a cls))
              (return-from applicable-type-spec-method-p nil)))
      t)))

以下のようにして使います。

(in-package :cl-user)

(type-spec-class:define-type-spec color '(member :red :blue :green))

(defgeneric what-is (obj)
  (:generic-function-class type-spec-class:<type-spec-gf>))

(defmethod what-is ((obj t))
  "unknown")
  
(defmethod what-is ((obj symbol))
  "symbol")

(defmethod what-is ((obj color))
  (format nil "color ~A" obj))

(what-is :red)
;; => "color RED"
(what-is :hoge)
;; => "symbol"
(what-is 2)
;; => "unknown"
 

<type-spec-meta>のインスタンス(であるクラスのインスタンス)を引数にとるメソッドは通常のメソッドよりも優先度が高くなっていますが、 最初に見つかったものを呼び出しているだけなので、<type-spec-meta>のインスタンス間での優先度は扱っていません。