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 |

2008-12-10

MooseをCLで再現してみたい

| 22:34 | MooseをCLで再現してみたい - わだばLisperになる を含むブックマーク はてなブックマーク - MooseをCLで再現してみたい - わだばLisperになる

今年はPerlでMooseという言葉を良く聞いたのですが、一体どんな感じなのだろうということで、CLで再現してみようと思い立ちました。

ちゃんとやればMOPの練習になるかもしれません。

それはさておき、外見だけ真似てみました。

package Point;
use strict;
use warnings;
use Moose;

has 'x' => (is => 'rw', isa => 'Int');
has 'y' => (is => 'rw', isa => 'Int');
sub clear {
  my $self = shift;
  $self->x(0);
  $self->y(0);
}

package Point3D;
use strict;
use warnings;
use Moose;
extends 'Point';
has 'z' => (is => 'rw', isa => 'Int');
after 'clear' => sub {
  my $self = shift;
  $self->z(0);
};

こういうのを

(defmoose point ()
  (:has x :is rw :isa integer)
  (:has y :is rw :isa integer)
  (:sub clear ()
        (setf (x self) 0
              (y self) 0)))

(defmoose point-3d (point)
  (:has z :is rw)
  (:after clear ()
          (setf (z self) 0)))

こう書いたらどうかと。

;; 試す
(let ((p (make-instance 'point-3d)))
  (clear p)
  (setf (x p) 30)
  (describe p))
;>>>
;#<POINT-3D #x30004287806D>
;Class: #<STANDARD-CLASS POINT-3D>
;Wrapper: #<CLASS-WRAPPER  #x3000426FB8FD>
;Instance slots
;X: 30
;Y: 0
;Z: 0

当初は、やはり矢印が格好良いので矢印を活かしたかったんですが、

(defmoose point-3d (point)
  (:has z => ((:is => 'rw)
              (:isa => 'integer)))
  (:after clear
          => (sub clear ()
                  (setf (-> self z) 0))))

どうも矢印を書くのが面倒なので普通のplistにしてしまいました。

ちなみに、今のところマクロで変形しているだけでMOPの鱗片さえありません(´▽`*)

メッセージセンドでもなく普通の総称関数です。

一応:afterメソッドにも対応してみました。変形してるだけですが…。

(defpackage :moose
  (:use :cl))

(in-package :moose)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun get-hases (attributes)
    (remove :has attributes :key #'car :test-not #'eq))

  (defun get-subs (attributes)
    (remove :sub attributes :key #'car :test-not #'eq))
  
  (defun ensure-has-attributes (class-name attributes)
    (declare (ignore class-name))
    (mapcar (lambda (x)
            (let ((has (getf x :has))
                  (is (getf x :is))
                  (isa (getf x :isa)))
              `(,has
                ,@(and is (list 
                           (case is
                             (rw :accessor)
                             (ro :reader)
                             (otherwise (error "malformed attributes")))
                                        ;(intern (format nil "~:@(~A.~A~)" class-name has))
                           has
                           ))
                ,@(and isa (list :type isa)))))
            (get-hases attributes)))
  
  (defun ensure-sub-attributes (class-name attributes)
    (mapcar (lambda (x)
              (let* ((args (cdr x)))
                `(defmethod ,(first args) ((self ,class-name) ,@(second args)) ,@(cddr args))))
            (get-subs attributes)))
  
  (defun get-afters (attributes)
    (remove :after attributes :key #'car :test-not #'eq))
  
  (defun ensure-after-attributes (class-name attributes)
    (mapcar (lambda (x)
              (let ((args (cdr x)))
                `(defmethod ,(first args) :after ((self ,class-name) ,@(second args)) ,@(cddr args))))
            (get-afters attributes))))

;; 本体
(defmacro defmoose (name (&rest extends) &rest attributes)
  `(progn
     (defclass ,name ,extends
       ,(ensure-has-attributes name attributes))
     ,@(ensure-sub-attributes name attributes)
     ,@(ensure-after-attributes name attributes)))

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20081210