Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2011-02-26

同じ:testを指定するのが面倒

| 14:00 | 同じ:testを指定するのが面倒 - わだばLisperになる を含むブックマーク はてなブックマーク - 同じ:testを指定するのが面倒 - わだばLisperになる

(member "bar"
        (delete "foo"
                (delete-duplicates
                  (copy-list '(delete "foo" "bar" "baz" "foo" "FOO")))))

のような物を書いた場合、比較するものが文字列になるため、デフォルトのeqlでは比較できていないことになります。

きちんと比較できるようにするには、:testにstring=などを指定して比較にstring=を使うことにしてやれば良いのですが、

(member "bar"
        (delete "foo"
                (delete-duplicates
                  (copy-list '(delete "foo" "bar" "baz" "foo" "FOO"))
                  :test #'string=)
                :test #'string=)
        :test #'string=))

という風になります。長くて重複しているわけです。

これが面倒だなあと以前から思っていたので、どうにかできないかと思ってマクロを書いてみました。

(defvar *foo-operators*
  (atap ()
    ;; clパッケージから:testを受け付けるオペレーターを探す
    (do-symbols (sym :cl)
      (when (and (fboundp sym)
                 (member 'test (member '&key (kl:flatten (swank::arglist sym)))
                         :key #'princ-to-string :test #'string-equal))
        (push sym it)))))

(defun add-test (expr test-fn)
  (labels ((*self (expr)
             (destructuring-bind (&optional car &rest cdr) expr
               (cond ((null expr) () )
                     ;;
                     ((consp car)
                      (cons (*self car) (*self cdr)))
                     ;;
                     ((eq 'quote car) expr)
                     ;;
                     ((member car *foo-operators*)
                      `(,car ,@(*self cdr) :test ,test-fn))
                     ;;
                     ('T (cons car (*self cdr)))))))
    (*self expr)))

(defmacro with-default-test (test &body body)
  `(progn
     ,@(add-test body test)))

上のatapは、

(let ((it () ))
  ...
  it)

と等価です。RubyのtapやGaucheのrlet1のアナフォリック版というところです。

使い方は、

(with-default-test (f (x y) (string-equal x y))
  (member "bar"
          (delete "foo"
                  (delete-duplicates
                   (copy-list '(delete "foo" "bar" "baz" "foo" "FOO"))))))

という感じに書くと

(progn
 (member "bar"
         (delete "foo"
                 (delete-duplicates
                  (copy-list '(delete "foo" "bar" "baz" "foo" "FOO"))
                  :test (f (x y) (string-equal x y)))
                 :test (f (x y) (string-equal x y)))
         :test (f (x y) (string-equal x y))))

という風になります。

ちなみに、既に:testが指定されていたらどうするかは考えていないのですが、指定のものを優先とするのが妥当かなと思っています。