아겔로그

Ping 16/Oct/2020

🗓️ 16 Oct, 2020

ADT1만큼 만들어 쓰는 것은 아니지만, 그냥 Kotlin, Python의 dataclass 정도는 쓰고 싶어서 CommonLisp 매크로를 만들어봤다.2

equals 라이브러리를 써서 동치 비교와 CLOS의 print-object generic function을 구현해서 to-string 정도만 되도록 만들어 봤다.

macro body 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

(defmacro define-data-class
    (class-name parent-classes slot-names
     &key (no-print-slot-names nil) (no-equals-slot-names nil))
  (flet ((accessor-symbol (slot-name)
           (alexandria:format-symbol *package*
                                     "~a-~a" class-name slot-name)))  
    (list 'progn          
          ;; defclass
          (let ((slot-defs (loop for slot-name in slot-names
                                 collecting `(,slot-name
                                              :initarg ,(alexandria:make-keyword slot-name)
                                              :accessor ,(accessor-symbol slot-name)))))
            `(defclass ,class-name ,parent-classes ,slot-defs))

          ;; defmethod print-object
          (let* ((print-slot-names (set-difference slot-names
                                                   no-print-slot-names))
                 (fmt-ctrl (format nil "~{~a=~~a~^, ~}" print-slot-names)))
            `(defmethod print-object ((obj ,class-name) stream)
               (print-unreadable-object (obj stream :type t)
                 (with-slots ,print-slot-names obj
                   (format stream ,fmt-ctrl ,@print-slot-names)))))

          ;; defmethod equals:equals
          (let* ((equals-slot-names (set-difference slot-names
                                                    no-equals-slot-names))
                 (equals-exprs (loop for equals-slot-name in equals-slot-names
                                     collecting `(equals:equals (slot-value lhs (quote ,equals-slot-name))
                                                                (slot-value rhs (quote ,equals-slot-name))))))
            `(defmethod equals:equals ((lhs ,class-name) (rhs ,class-name) &rest args)
               (declare (ignore args))
               (and t ,@equals-exprs)))
          )))

synopsis / usage 

1
2
3
4
5
6

(define-data-class animal () (name age))

(define-data-class bird (animal) ())

(equals:equals (make-instance 'animal :name "foo" :age 18)
               (make-instance 'animal :name "foo" :age 18))

오랬만에 재밌었다.

Footnotes

1

https://en.wikipedia.org/wiki/Algebraic_data_type

2

사실 ADT을 정의하는 매크로 라이브러리와 이를 위한 패턴매칭 라이브러리가 커먼리습에 이미 있지만. 더 간단하게만 쓰고 싶어서.