Макрос со списком макросов в качестве аргумента в 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)))