X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/7553e5e8a09f7ee07bf759e99b996925b060f9b9..1d51a2eea8537084e9e681c297422047ae858989:/src/mewa.lisp diff --git a/src/mewa.lisp b/src/mewa.lisp index 25c8f07..ca40f24 100644 --- a/src/mewa.lisp +++ b/src/mewa.lisp @@ -1,67 +1,18 @@ -(declaim (optimize (speed 2) (space 3) (safety 0))) - (in-package :lisp-on-lines) -(defparameter *default-type* :ucw) - -(define-layered-class description () - ((description-type - :initarg :type - :accessor description.type - :initform 'viewer - :special t) - (description-layers - :initarg :layers - :accessor description.layers - :initform nil - :special t) - (description-properties - :accessor description.properties - :initform nil - :special t) - (described-object - :layered-accessor object - :initform nil - :special t) - (description-default-attributes - :accessor default-attributes - :initarg :default-attributes - :initform nil - :special t) - (description-attributes - :accessor attributes - :initarg :attributes - :initform nil - :special t))) - -(defmethod print-object ((self description) stream) - (print-unreadable-object (self stream :type t) - (with-slots (description-type) self - (format stream "~A" description-type)))) - ;;;; * Occurences +;;;; Occurences can be thought of as the class of a description. +;;;; Most of the occurence stuff is depreciated now. -(defvar *occurence-map* (make-hash-table) - "a display is generated by associating an 'occurence' -with an instance of a class. This is usually keyed off class-name, -although an arbitrary occurence could be used with an arbitrary class.") - -(define-layered-class - standard-occurence (description) - ((occurence-name :accessor name :initarg :name) - (attribute-map :accessor attribute-map :initform (make-hash-table))) - (:documentation "an occurence holds the attributes like a class holds slot-definitions. -Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects.")) +Attributes are the yetadata used to display, validate, and otherwise manipulate actual values stored in lisp objects." (defun find-or-create-occurence (name) "Returns the occurence associated with this name." - (let ((occurence (gethash name *occurence-map*))) - (if occurence - occurence - (let ((new-occurence (make-instance 'standard-occurence :name name))) - (setf (gethash name *occurence-map*) new-occurence) - new-occurence)))) + (let ((description (find-description name))) + (if description + (class-of description) + (class-of (ensure-description name))))) (defun clear-occurence (occurence) "removes all attributes from the occurence" @@ -73,19 +24,54 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (:method ((name symbol)) (find-or-create-occurence name)) (:method ((instance standard-object)) - (find-or-create-occurence (class-name (class-of instance))))) + (multiple-value-bind (occ new?) + (find-or-create-occurence (class-name-of instance)) + (if new? + (initialize-occurence-for-instance occ instance) + occ)))) + +(defun list-attributes (occurence) + (let (res) + (maphash (lambda (k v) + (declare (ignore v)) + (push k res)) + (attribute-map occurence)) + res)) + + +(defmethod make-attribute-using-slot-definition (slotd) + (make-attribute + :name (closer-mop:slot-definition-name slotd) + :type-spec (closer-mop:slot-definition-type slotd) + :type (first (remove-if (lambda (item) + (or + (eql item 'or) + (eql item 'null) + (eql item nil))) + (ensure-list (closer-mop:slot-definition-type slotd)))))) + +(defmethod initialize-occurence-for-instance (occurence instance) + (let ((slots (closer-mop:class-slots (class-of instance)))) + (dolist (s slots) + (let ((att (make-attribute-using-slot-definition s))) + (setf (find-attribute occurence (attribute-name att)) att))) + occurence)) + + +;;;; * Attributes + (define-layered-class attribute (description) - ((attribute-name :layered-accessor attribute.name + ((attribute-name :layered-accessor attribute-name :initarg :name :initform (gensym "ATTRIBUTE-") :special t) (occurence :accessor occurence :initarg :occurence :initform nil) (label :initarg :label :layered-accessor label :initform nil :special t))) -;;;; * Attributes + (defmethod print-object ((self attribute) stream) (print-unreadable-object (self stream :type t) (with-slots (attribute-name description-type) self @@ -96,9 +82,13 @@ Attributes are the metadata used to display, validate, and otherwise manipulate ((setter :accessor setter :initarg :setter :special t :initform nil) (getter :accessor getter :initarg :getter :special t :initform nil) (value :accessor value :initarg :value :special t) - (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil)) + (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil) + (typespec :accessor type-spec :initarg :type-spec :initform nil)) (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc.")) +(define-layered-method label :around ((attribute standard-attribute)) + (or (call-next-method) (attribute-name attribute))) + (defmacro defattribute (name supers slots &rest args) (let* ( (type-provided-p (second (assoc :type-name args))) @@ -129,11 +119,6 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (not (find-attribute-class-for-type name))) `(defmethod find-attribute-class-for-type ((type (eql ',type))) ',name))))) -(define-layered-class - display-attribute (attribute) - () - (:documentation "Presentation Attributes are used to display objects -using the attributes defined in an occurence. Presentation Attributes are always named using keywords.")) (defun clear-attributes (name) "removes all attributes from an occurance" @@ -149,7 +134,7 @@ using the attributes defined in an occurence. Presentation Attributes are always :properties args args)) -(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys) +(defmethod ensure-attribute ((occurence description) &rest args &key name &allow-other-keys) "Creates an attribute in the given occurence" (let ((attribute (apply #'make-attribute :occurence occurence args))) (setf (find-attribute occurence name) attribute))) @@ -157,7 +142,7 @@ using the attributes defined in an occurence. Presentation Attributes are always (defmethod find-attribute ((occurence null) name) nil) -(defmethod find-attribute ((occurence standard-occurence) name) +(defmethod find-attribute ((occurence description) name) (or (gethash name (attribute-map occurence)) (let* ((class (ignore-errors (find-class (name occurence)))) (class-direct-superclasses @@ -173,9 +158,9 @@ using the attributes defined in an occurence. Presentation Attributes are always name))) attribute))))) -(defmethod find-all-attributes ((occurence standard-occurence)) +(defmethod find-all-attributes ((occurence description)) (loop for att being the hash-values of (attribute-map occurence) - collect att)) + collect att)) (defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys) (declare (ignore name type)) @@ -210,15 +195,14 @@ ATTRIBUTE-SPEC: a list of (type name &rest initargs)" (setf (gethash attribute-name (attribute-map occurence)) attribute)) - (defmethod find-attribute ((attribute-with-occurence attribute) attribute-name) (find-attribute (occurence attribute-with-occurence) attribute-name)) (defmethod set-attribute-properties ((occurence-name t) attribute properties) - (setf (description.properties attribute) (plist-nunion + (setf (description-properties attribute) (plist-nunion properties - (description.properties attribute))) - (loop for (initarg value) on (description.properties attribute) + (description-properties attribute))) + (loop for (initarg value) on (description-properties attribute) by #'cddr with map = (initargs.slot-names attribute) do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map))) @@ -236,14 +220,14 @@ ATTRIBUTE-SPEC: a list of (type name &rest initargs)" otherwise, (setf find-attribute)" (let ((att (find-attribute occurence-name attribute-name))) (if (and att inherit (or (eql (car attribute-spec) - (description.type att)) + (description-type att)) (eq (car attribute-spec) t))) (set-attribute-properties occurence-name att (cdr attribute-spec)) (setf (find-attribute occurence-name attribute-name) (cons (car attribute-spec) (plist-nunion (cdr attribute-spec) - (when att (description.properties att)))))))) + (when att (description-properties att)))))))) (defmethod perform-define-attributes ((occurence-name t) attributes) (loop for attribute in attributes @@ -258,21 +242,14 @@ otherwise, (setf find-attribute)" ,@(loop for occurence-name in occurence-names collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions))))) -(defmethod find-display-attribute (occurence name) - (find-attribute occurence (intern (symbol-name name) "KEYWORD"))) -(defmethod find-description (object type) - (let ((occurence (find-occurence object))) - (or (find-display-attribute - occurence - type) - occurence))) + ;;"Unused???" (defmethod setter (attribute) (warn "Setting ~A in ~A" attribute *context*) - (let ((setter (getf (description.properties attribute) :setter)) - (slot-name (getf (description.properties attribute) :slot-name))) + (let ((setter (getf (description-properties attribute) :setter)) + (slot-name (getf (description-properties attribute) :slot-name))) (cond (setter setter) (slot-name @@ -301,13 +278,13 @@ we return slot-value-or nil either boundp or not." slot-value-or-nil (slot-value instance (slot-name attribute)))))) - ((and (slot-exists-p instance (attribute.name attribute))) + ((and (slot-exists-p instance (attribute-name attribute))) (setf existsp t) - (when (slot-boundp instance (attribute.name attribute)) + (when (slot-boundp instance (attribute-name attribute)) (setf boundp t slot-value-or-nil (slot-value instance - (attribute.name attribute)))))) + (attribute-name attribute)))))) (VALUES slot-value-or-nil existsp boundp))) (define-layered-method attribute-value (instance (attribute standard-attribute)) @@ -330,16 +307,16 @@ we return slot-value-or nil either boundp or not." (funcall setter value instance)) ((and (slot-boundp attribute 'slot-name) slot-name) (setf (slot-value instance slot-name) value)) - ((and (slot-exists-p instance (attribute.name attribute))) - (setf (slot-value instance (attribute.name attribute)) value)) + ((and (slot-exists-p instance (attribute-name attribute))) + (setf (slot-value instance (attribute-name attribute)) value)) (t (error "Cannot set ~A in ~A" attribute instance))))) ;;;; ** Default Attributes - - +;;;; TODO: This is mosty an ugly hack and should be reworked. +;;;; ;;;; The default mewa class contains the types use as defaults. ;;;; maps meta-model slot-types to slot-presentation @@ -356,35 +333,25 @@ we return slot-value-or nil either boundp or not." (integer integer) (currency currency) (clsql:generalized-boolean boolean) - (foreign-key foreign-key)) - -(defun find-presentation-attributes (occurence-name) - (loop for att in (find-all-attributes occurence-name) - when (typep att 'display-attribute) - collect att)) + (foreign-key has-a)) (defun attribute-to-definition (attribute) - (nconc (list (attribute.name attribute) - (description.type attribute)) - (description.properties attribute))) + (nconc (list (attribute-name attribute) + (description-type attribute)) + (description-properties attribute))) (defun find-default-presentation-attribute-definitions () - (if (eql *default-attributes-class-name* 'default) - (mapcar #'attribute-to-definition (find-presentation-attributes 'default)) - (remove-duplicates (mapcar #'attribute-to-definition - (append - (find-presentation-attributes 'default) - (find-presentation-attributes - *default-attributes-class-name*)))))) + nil) + (defun gen-ptype (type) (let* ((type (if (consp type) (car type) type)) (possible-default (find-attribute *default-attributes-class-name* type)) (real-default (find-attribute 'default type))) (cond (possible-default - (description.type possible-default)) + (description-type possible-default)) (real-default - (description.type real-default)) + (description-type real-default)) (t type)))) (defun gen-presentation-slots (instance)