Метаобъектный протокол Common Lisp на примере реализации прототипной объектной системы
Common Lisp, а точнее, его объектная система, CLOS, предоставляет пользователю языка совершенно замечательный механизм, а именно, метаобъектный протокол.
К сожалению, очень часто этот компонент языка незаслуженно обходится без должного внимания, и в данной статье я постараюсь это несколько компенсировать.
Вообще, что такое метаобъектный протокол? Очевидно, это слой объектной системы, который, судя по названию, каким-либо образом оперирует над ней самой, и управляет ей.
Для чего он нужен? На самом деле, в зависимости от языка и объектной системы, список применений может быть практически безграничен. Это как добавление коду декларативности (аннотации в Java и аттрибуты в C#), так и разнообразная генерация кода и классов в рантайме (здесь можно вспомнить разнообразные persistance и ORM фреймворки), так и многое другое.
С моей лично точки зрения, лучше всего метаобъектные протоколы себя зарекомендовали со стороны закрепления паттернов проектирования на уровне объектной системы. Такие паттерны, как, скажем, синглтон, которые в языках без достаточно развитого ООП приходится снова и снова реализовывать методом copy-n-paste, в моем любимом Common Lisp создаются буквально из пары десятков строчек кода и переиспользуются в дальнейшем исключительно указанием метакласса[1].
Тем не менее, в нижеследующем тексте я хочу сосредоточиться на кое-чем более интересном, а именно — на изменении правил работы самой объектной системы, самих ее основ. Именно добавление возможностей подобного изменения и было ключевой целью разработчиков метаобъектного протокола для Common Lisp.
Итак, дальнейший текст будет посвящен созданию прототипной объектной системы, подобной JavaScript, в Common Lisp, с использованием метаобъектного протокола и интеграцией ее в CLOS. Полный код проекта доступен на github[2].
Собственно первое, что нужно сделать, это создать метакласс для всех классов, участвующих в нашей прототипной системе.
(defclass prototype-class (standard-class) () (: documentation «Metaclass for all prototype classes»)) Вот так вот просто. На самом деле, класс классов нам нужен исключительно для переопределения стандартных механизмов работы со слотами (т.е. полями класса) у наших объектов, и об этом чуть подробнее.
В CLOS MOP каждый слот объекта в классе представляется так называемыми slot-definition. Slot-definition, как понятно из названия, определяют метаинформацию о полях класса, а бывают они двух видов:
direct-slot-definiton Собственно, как, возможно, понятно из названия, представляют собой они то, что мы непосредственно указали при определении класса, скажем с помощью формы defclass. effective-slot-definition — «Определение фактического слота». Они описывают слоты, которые существуют, грубо говоря, в объектах нашего класса. Чтобы разница была понятна, стоит подробнее описать протокол инициализации классов.
В CLOS, при создании (определении) класса в нем (в его метаобъекте) до определенного времени хранится непосредственно только та информация, которую мы указали (скажем, в defclass). Это какая-то информация об определенных в нем полях (direct-slot-definition), это список классов от которых он наследуется, и разные другие вещи которые мы, еще раз повторюсь, непосредственно указали при создании. После создания класса, мы некоторое время спустя можем его редактировать.
В определенный момент, с метаобъектом класса происходит некоторая вещь, называемая финалазацией. Обычно она происходит автоматически, в основном при создании первого объекта класса, но может также быть вызывана руками.
В принципе, можно провести некоторые параллели со статическими конструкторами классов в языках вроде C#. Финализация, грубо говоря, завершает создание класса. В этот момент высчитывается так называемый Class Precedence List (а если по-русски, «список порядка наследования» класса, грубо говоря топологическая сортировка всех классов, от которых наш наследуется), и на основе этой информации определяются «фактические» слоты, которые объекты нашего класса будут хранить.
Так вот, «определение непосредственного слота» хранит только самую общую информацию о слоте, в то время как определение «фактического» хранит в том числе информацию об индексе слота в памяти объекта, которая не может быть вычислена до финализации класса.
В принципе, все описанные механизмы можно переопределить через метаобъектный протокол, но мы ограничимся лишь несколькими.
Создадим наши классы определений слотов.
(defclass direct-hash-slot-definition (standard-direct-slot-definition) () (: default-initargs: allocation: hash))
(defclass effective-hash-slot-definition (standard-effective-slot-definition) () (: default-initargs: allocation: hash)) Теперь переопределим две обобщенные функции из MOP, которые указывают, классы каких определений слотов наш метакласс должен использовать, при их, определений слотов, создании.
(defmethod direct-slot-definition-class ((class prototype-class) &rest initargs) (declare (ignore initargs)) (find-class 'direct-hash-slot-definition))
(defmethod effective-slot-definition-class ((class prototype-class) &rest initargs) (declare (ignore initargs)) (find-class 'effective-hash-slot-definition)) Выше видно, что метаобъекты определений слотов принимают аргумент : allocation. Что это? Это спецификатор, указывающий, где выделяется место под поля объектов. Стандарт CL упоминает о двух видах таких спецификаторов. Первый — : class, который означает что место будет выделяться в самом классе, т.е. это аналог статических полей из других языков, и второй — : instance — место будет выделяться для каждого объекта класса, обычно в некотором массиве связаным с ним. Мы же указали свой спецификатор — : hash. Зачем? А затем, что по дефолту, поля у нас будут храниться в некоторой хэш-табличке, связанной с объектом, подобно тому как это делается в JavaScript.
Где же мы определим слот с хэш-табличкой? И, мы ведь где-то еще хотим хранить прототип объекта. Мы поступим следующим образом — мы определим класс prototype-object, который будет у нас вершиной иерархии всех классов, работающих с нашей системой. Как видно ниже, слоты с прототипом и с полями мы определим с instance allocation.
Прежде, чем мы создадим этот класс, мы должны разрешить нашим классам вида prototype-class наследоваться от стандартных классов и обратно. Функция validate-superclass вызывается в процессе финализации, который описан выше. В случае если хотя бы один из вариантов наследник-родитель, для любого из наследуемых классов, вернул nil, стандартный механизм CLOS сигнализирует исключение.
(defmethod validate-superclass ((class prototype-class) (super standard-class)) t)
(defmethod validate-superclass ((class standard-class) (super prototype-class)) t)
(defclass prototype-object () ((hash: initform (make-hash-table: test #'eq) : reader hash : allocation: instance : documentation «Hash table holding: HASH object slots») (prototype: initarg: prototype : accessor prototype : allocation: instance : documentation «Object prototype or NIL.»)) (: metaclass prototype-class) (: default-initargs: prototype nil) (: documentation «Base class for all prototype objects»)) Давайте дополнительно определим две функции, подобные аналогичным из стандартной CLOS. Что они делают, думаю понятно:
(defun prototype-of (object) «Retrieves prototype of an OBJECT» (let ((class (class-of object))) (when (typep class 'prototype-class) (prototype object))))
(defgeneric change-prototype (object new-prototype) (: documentation «Changes prototype of OBJECT to NEW-PROTOTYPE») (: method ((object prototype-object) new-prototype) (setf (prototype object) new-prototype))) Теперь небольшой хак. В стандартной CLOS в случае, если мы в defclass не указали ни одного класса-родителя являющегося standard-object, а метакласс нашего класса — обычный standard-class, то такой класс, собственно сам standard-object, инжектится в список классов, от которых мы наследуемся. Мы поступим так же с нашими prototype-class и prototype-object. Для этого нужно переопределить стандартные функции, используемые конструктором объектов.
(defun fix-class-initargs (class &rest args &key ((: direct-superclasses dscs) '()) &allow-other-keys) «Fixup: DIRECT-SUPERCLASSES argument for [RE]INITIALIZE-INSTANCE gf specialized on prototype classes to include PROTOTYPE-OBJECT in superclass list» (remf args: direct-superclasses) (unless (or (eq class (find-class 'prototype-object)) (find-if (lambda © (unless (symbolp c) (setf c (class-name c))) (subtypep c 'prototype-object)) dscs)) (setf dscs (append dscs (list (find-class 'prototype-object))))) (list* : direct-superclasses dscs args))
(defmethod initialize-instance: around ((class prototype-class) &rest args &key &allow-other-keys) (apply #'call-next-method class (apply #'fix-class-initargs class args)))
(defmethod reinitialize-instance: around ((class prototype-class) &rest args &key &allow-other-keys) (apply #'call-next-method class (apply #'fix-class-initargs class args))) Теперь самое интересное.
Первое — чтобы работа со слотами объектов шла через хэш-табличку, хранящуюся у нас в объектах, нам нужно переопределить для наших классов четыре стандартных операции работы со слотами —, а именно: взятие значения слота, установка оного, проверка на связанность слота со значением и удаление такой связи. Все эти операции прекрасно реализуются хэш-табличкой; внутри этих операций, мы проверяем, является ли : allocation слота : hash, что указывает на то что наш слот хранится именно в ней, и если нет — то используем стандартный механизм доступа к полям объекта CLOS.
(defmethod slot-boundp-using-class ((class prototype-class) (object prototype-object) slotd) (if (eq: hash (slot-definition-allocation slotd)) (nth-value 1 (gethash (slot-definition-name slotd) (hash object))) (call-next-method)))
(defmethod slot-makunbound-using-class ((class prototype-class) (object prototype-object) slotd) (if (eq: hash (slot-definition-allocation slotd)) (remhash (slot-definition-name slotd) (hash object)) (call-next-method)))
(defmethod slot-value-using-class ((class prototype-class) (object prototype-object) slotd) (if (eq: hash (slot-definition-allocation slotd)) (values (gethash (slot-definition-name slotd) (hash object))) (standard-instance-access object (slot-definition-location slotd))))
(defmethod (setf slot-value-using-class) (new-value (class prototype-class) (object prototype-object) slotd) (if (eq: hash (slot-definition-allocation slotd)) (values (setf (gethash (slot-definition-name slotd) (hash object)) new-value)) (setf (standard-instance-access object (slot-definition-location slotd)) new-value))) Теперь прототипы. Как известно, в JavaScript значение поля ищется по цепочке прототипов. В случае, если поля в объекте нет, рекурсивно обходится вся иерархия, и в случае отсутствия поля у какого-либо из объектов, возвращается undefined. В то же время, в JS существует механизм «перекрытия» полей. Это значит, что если в объекте устанавливается/определяется поле с именем, аналогичным имени из полей какого-либо из объектов в иерархии прототипов, то при следующем доступе к этому полю, значение будет браться именно из него, без какого-либо следования по иерархии.
Мы реализуем аналогичную функциональность. Для этого нам потребуется переопределить обобщенную функцию slot-missing. Вызывается она тогда, когда функции работы со слотами (slot-value, (setf slot-value), slot-boundp, slot-makunbound) обнаруживают отсутствия поля с запрашиваемым именем в классе объекта. Эта обобщенная функция принимает крайне удобный набор аргументов — метаобъект класса объекта, сам объект, имя поля, имя «провалившейся» операции, и, для операции установки значения — новое значение поля.
Поступим следующим образом. До переопределения этой функции, создадим дополнительный класс сигналов (иключений Common Lisp), объекты которого будут выбрасываться в случае обнаружения отсутствия прототипа у объекта. Также, создадим дополнительный аналог вышеопределенной функции prototype-of.
(define-condition prototype-missing (condition) () (: documentation «Signalled when an object is not associated with a prototype.»))
(defun %prototype-of (class instance) «Internal function used to retreive prototype of an object» (if (typep class 'prototype-class) (or (prototype instance) (signal 'prototype-missing)) (signal 'prototype-missing))) Теперь определим наш метод. Схема работы следующая: для двух из четырех операций, мы рекурсивно обходим иерархию прототипов, и в конечном итоге выбрасываем исключение prototype-missing. Сверху стека вызовов мы устанавливаем обработчик, который, перехватывая сигнал, возвращает нам некоторое дефолтное значение — в данном случае nil. Две другие операции, как было объяснено выше, в рекурсивном обходе прототипов не нуждаются.
(defvar *prototype-handler* nil «Non-NIL when PROTOTYPE-MISSING handler is already installed on call stack.»)
(defun %slot-missing (class instance slot op new-value) «Internal function for performing hash-based slot lookup in case of it is missing from class definition.» (let ((hash (hash instance))) (symbol-macrolet ((prototype (%prototype-of class instance))) (case op (setf (setf (gethash slot hash) new-value)) (slot-makunbound (remhash slot hash)) (t (multiple-value-bind (value present) (gethash slot hash) (ecase op (slot-value (if present value (slot-value prototype slot))) (slot-boundp (if present t (slot-boundp prototype slot))))))))))
(defmethod slot-missing ((class prototype-class) (instance prototype-object) slot op &optional new-value) (if *prototype-handler* (%slot-missing class instance slot op new-value) (handler-case (let ((*prototype-handler* t)) (%slot-missing class instance slot op new-value)) (prototype-missing () nil)))) Готово! Собственно, не более чем за 150 строк кода мы получили работающую прототипную объектно-ориентированную систему, подобную таковой в JavaScript. Более того, эта система полностью интегрирована со стандартной CLOS, и допускает, скажем, участие «обычных» объектов в иерархии прототипов. Другая особенность — мы можем совсем не создавать своих классов объектов, а обходиться лишь одним prototype-object, в случае если мы хотим от нее поведения, полностью идентичного JS.
Что можно добавить? Наверное, поверх такой системы с помощью reader-макросов можно сделать JSON-подобный синтаксис. Но, это уже тема отдельной статьи :)
Напоследок несколько примеров:
(defvar *proto* (make-instance 'prototype-object))
(defclass foo () ((a: accessor foo-a)) (: metaclass prototype-class))
(defvar *foo* (make-instance 'foo: prototype *proto*))
(defvar *bar* (make-instance 'prototype-object: prototype *foo*))
(setf (slot-value *proto* 'x) 123)
(slot-value *bar* 'x) ;;; ==> 123
(setf (foo-a *foo*) 456)
(slot-value *bar* 'a) ;;; ==> 456
(setf (slot-value *bar* 'a) 789)
(setf (foo-a *foo*) 'abc)
(slot-value *bar* 'a) ;;; ==> 789 ;;; because we’ve introduced new property for *bar*
(defclass quux () ((the-slot: initform 'the-value)) (: documentation «Simple standard class»))
(defvar *quux* (make-instance 'quux))
(change-prototype *bar* *quux*)
(slot-value *bar* 'the-slot) ;;; ==> THE-VALUE
(slot-value *bar* 'x)
;;; When attempting to read the slot’s value (slot-value), the slot
;;; X is missing from the object #
