Макрос со списком макросов в качестве аргумента в Common Lisp

Question

В Common Lisp, как определить "мета-макрос", который принимает в качестве аргумента список макросов (и других аргументов) и компонует эти макросы для получения желаемого кода.

Проблема эквивалентна написанию "макроса высшего порядка", который определяет макрос из списка переменных других макросов.

Конкретная ситуация, вызывающая вопрос, для меня - эксперимент с CLSQL, где я хочу повторно выразить класс сотрудников из CLSQL-testsuite.

(clsql:def-view-class employee ()
  ((employee-id
    :db-kind :key
    :db-constraints (:not-null)
    :type integer)
   (first-name
    :accessor employee-first-name
    :type (string 30)
    :initarg :first-name)
   (last-name
    :accessor employee-last-name
    :type (string 30)
    :initarg :last-name)
   (email
    :accessor employee-email
    :type (string 100)
    :initarg :email)
   (company-id
     :type integer
     :initarg :company-id)
   (company
    :accessor employee-company
    :db-kind :join
    :db-info (:join-class company
              :home-key companyid
              :foreign-key companyid
              :set nil))
   (manager-id
    :type integer
    :nulls-ok t
    :initarg :manager-id)
   (manager
    :accessor employee-manager
    :db-kind :join
    :db-info (:join-class employee
              :home-key managerid
              :foreign-key emplid
              :set nil))))

как

(def-view-class-with-traits employee ()
  (trait-mapsto-company trait-mapsto-manager)
  ((employee-id
    :db-kind :key
    :db-constraints (:not-null)
    :type integer)
   (first-name
    :accessor employee-first-name
    :type (string 30)
    :initarg :first-name)
   (last-name
    :accessor employee-last-name
    :type (string 30)
    :initarg :last-name)
   (email
    :accessor employee-email
    :type (string 100)
    :initarg :email)))

Наличие этого метода будет способствовать согласованности и краткости при определении сложных схем базы данных.

Я определил две черты, которые мне нужны как

(defmacro trait-mapsto-company (class super slots &rest cl-options)
  (declare (ignore super slots cl-options))
  (let ((company-accessor-name
          (intern (concatenate 'string (symbol-name class) "-COMPANY"))))
    `((company-id
       :type integer
       :initarg :company-id)
      (company
       :accessor ,company-accessor-name
       :db-kind :join
       :db-info (:join-class company
                 :home-key companyid
                 :foreign-key companyid
                 :set nil)))))

(defmacro trait-mapsto-manager (class super slots &rest cl-options)
  (declare (ignore super slots cl-options))
  (let ((manager-accessor-name
          (intern (concatenate 'string (symbol-name class) "-MANAGER"))))
    `((manager-id
       :type integer
       :initarg :manager-id)
      (manager
       :accessor ,manager-accessor-name
       :db-kind :join
       :db-info (:join-class manager
                 :home-key managerid
                 :foreign-key emplid
                 :set nil)))))

Однако моя попытка написать def-view-class-with-traits сорван.

(defmacro def-view-class-with-traits (class super traits slots &rest cl-options)
  (let ((actual-slots
          (reduce (lambda (trait ax) (append (apply trait class super slots cl-options) ax))
                  traits
                  :initial-value slots)))
    `(clsql:def-view-class ,class ,super ,actual-slots ,@cl-options)))

В лямбде, используемой для уменьшения, trait означает макрос, и мое применение apply не имеет никакого смысла для Lisp - и это правильно! - но надеюсь передать мои намерения другим программистам.

Как позволить def-view-class-with-traits обработать список макросов traits соответствующим образом?

Answer 1

Я был бы гораздо менее удивительным, если бы вы определили признаки как сами классы и использовали нормальное наследование:

(def-view-class trait-mapsto-company ()
  ((company-id
    :type integer
    :initarg :company-id)
   (company
    :accessor company
    :db-kind :join
    :db-info (:join-class company
              :home-key company-id
              :foreign-key company-id
              :set nil))))

(def-view-class trait-mapsto-manager ()
  ((manager-id
    :type integer
    :initarg :manager-id)
   (manager
    :accessor manager
    :db-kind :join
    :db-info (:join-class manager
              :home-key managerid
              :foreign-key emplid
              :set nil)))

(def-view-class employee (trait-mapsto-company trait-mapsto-manager)
  ((employee-id
    :db-kind :key
    :db-constraints (:not-null)
    :type integer)
   (first-name
    :accessor employee-first-name
    :type (string 30)
    :initarg :first-name)
   (last-name
    :accessor employee-last-name
    :type (string 30)
    :initarg :last-name)
   (email
    :accessor employee-email
    :type (string 100)
    :initarg :email)))

Это, конечно, не делает имя метода доступа зависимым от имени класса наследования, но вы действительно этого хотите? Я считаю, что этот способ написания показывает, что это на самом деле нарушило бы разделительный принцип.

Answer 2

Способ "вызвать" макрос macroexpand-1:

(defmacro def-view-class-with-traits (class super traits slots
                                      &rest cl-options
                                      &environment env)
  (let ((tslots
           (loop for m in traits
                 append (macroexpand-1 (list* m class super slots options)
                                       env))))
    `(def-view-class ,class ,super (,@tslots ,@slots) ,@cl-options)))