From 6de8d30004efc9337b8c40d2ff2d0a76651d23eb Mon Sep 17 00:00:00 2001 From: drewc Date: Fri, 25 Jan 2008 00:54:03 -0800 Subject: [PATCH 1/1] Properties are special now! Added compatibility with special slots from contextl. also added inline descriptions and added them in display-attribute where they belong. darcs-hash:20080125085403-39164-31c580e9f256b6384d7a6d8cae8efcf302784565.gz --- lisp-on-lines.asd | 4 +- src/attribute.lisp | 517 ++++++++++++++------------ src/contextl-hacks.lisp | 23 +- src/description-class.lisp | 5 +- src/description.lisp | 40 +- src/display.lisp | 30 +- src/packages.lisp | 9 +- src/rofl.lisp | 223 +++++++++++ src/standard-descriptions/clos.lisp | 76 +++- src/standard-descriptions/inline.lisp | 16 + src/standard-descriptions/symbol.lisp | 2 +- src/standard-descriptions/t.lisp | 10 +- src/ucw/html-description.lisp | 119 ++++-- src/ucw/packages.lisp | 8 + src/ucw/standard-components.lisp | 5 +- 15 files changed, 786 insertions(+), 301 deletions(-) rewrite src/attribute.lisp (77%) create mode 100644 src/rofl.lisp create mode 100644 src/standard-descriptions/inline.lisp diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index abecfd6..bb4117b 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -41,6 +41,7 @@ OTHER DEALINGS IN THE SOFTWARE." :components ((:file "contextl-hacks") (:file "packages") + (:file "rofl") (:file "utilities") (:file "display") @@ -54,6 +55,7 @@ OTHER DEALINGS IN THE SOFTWARE." (:module :standard-descriptions :components ((:file "t") + (:file "inline") (:file "edit") (:file "symbol") (:file "list") @@ -63,7 +65,7 @@ OTHER DEALINGS IN THE SOFTWARE." :serial t)) :serial t - :depends-on (:contextl :arnesi :alexandria)) + :depends-on (:contextl :arnesi :alexandria :postmodern)) diff --git a/src/attribute.lisp b/src/attribute.lisp dissimilarity index 77% index e502859..2b66d42 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -1,229 +1,288 @@ -(in-package :lisp-on-lines) - -(define-layered-class direct-attribute-definition-class - (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition) - ((attribute-properties :accessor direct-attribute-properties - :documentation "This is an plist to hold the values of the attribute's properties as described by this direct attrbiute definition."))) - -(defmethod initialize-instance :after ((attribute direct-attribute-definition-class) &rest initargs) - (setf (direct-attribute-properties attribute) initargs)) - -(define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition) - ((direct-attributes :accessor attribute-direct-attributes) - (attribute-object :accessor attribute-object - :documentation "") - (attribute-object-initargs :accessor attribute-object-initargs))) - - -(define-layered-function attribute-value (object attribute)) - -(define-layered-method attribute-value (object attribute) - - (let ((fn (handler-case (attribute-function attribute) - (unbound-slot () nil)))) - (if fn - (funcall fn object) - (%attribute-value attribute)))) - -(defmethod attribute-description (attribute) - ;(break "description for ~A is (slot-value attribute 'description-name)") - (find-layer (slot-value attribute 'description-class)) -#+nil (let ((name (slot-value attribute 'description-name))) - (when name - (find-description name)))) - - -(define-layered-class standard-attribute () - - ((effective-attribute-definition :initarg effective-attribute - :accessor attribute-effective-attribute-definition) - (description-name) - (description-class :initarg description-class) - (initfunctions :initform nil) - (attribute-class :accessor attribute-class - :initarg :attribute-class - :initform 'standard-attribute - :layered t) - (name :layered-accessor attribute-name - :initarg :name) - (label :layered-accessor attribute-label - :initarg :label - :initform nil - :layered t - :special t - ) - (function - :initarg :function - :layered-accessor attribute-function - :layered t) - (value :layered-accessor %attribute-value - :initarg :value - :layered t))) - -(defmethod print-object ((object standard-attribute) stream) - (print-unreadable-object (object stream :type nil :identity t) - (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) - -(defgeneric eval-property-initarg (att initarg) - (:method ((attribute standard-attribute) initarg) - nil) - (:method ((attribute standard-attribute) (initarg (eql :function))) - t)) - -(defun prepare-initargs (att args) - (loop - :for (key arg) - :on args :by #'cddr - :nconc (list key - (if (eval-property-initarg att key) - (eval arg) - arg)))) - -(defvar *bypass-property-layered-function* nil) - -(define-layered-function property-layered-function (description attribute-name property-name) - (:method (description attribute-name property-name) - ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name) - (ensure-layered-function - (defining-description (intern (format nil "~A-~A-~A" - (description-print-name description) - attribute-name - property-name))) - - :lambda-list '(description)))) - - -(define-layered-method (setf slot-value-using-layer) - :in-layer (context t) - :around - (new-value class (attribute standard-attribute) property writer) - - (when (or *bypass-property-layered-function* ) - - (return-from slot-value-using-layer (call-next-method))) - - (let ((layer - ;;FIXME: this is wrong for so many reasons - (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context)) - :key #'class-name)))) - (boundp (slot-boundp-using-class class attribute property)) - (val (real-slot-value-using-class class attribute property))) - - (when (special-symbol-p val) - (return-from slot-value-using-layer (call-next-method))) - - (when (not boundp) - ;; * This slot has never been set before. - ;; create a method on property-layered-function - ;; so subclasses can see this new property. - (ensure-layered-method - (layered-function-definer 'property-layered-function) - `(lambda (description attribute property) - (declare (ignore description attribute property)) - ,val) - :in-layer layer - :specializers - (list (class-of - (attribute-description attribute)) - (closer-mop:intern-eql-specializer - (attribute-name attribute)) - (closer-mop:intern-eql-specializer - (closer-mop:slot-definition-name property))))) - - ;; specialize this property to this description. - - (ensure-layered-method - val - `(lambda (description) - (funcall ,(lambda() - new-value))) - :in-layer layer - :specializers (list (class-of (attribute-description attribute)))) - - ;; and return the set value as is custom - (slot-value-using-class class attribute property))) - - -(define-layered-method slot-value-using-layer - :in-layer (layer t) - :around (class (attribute standard-attribute) property reader) - - ;; (dprint "Getting the slot value of ~A" property) - - ;; We do some magic in here and i thought it - ;; would be called magically in call-next-method. - ;; This explicit call is good enough for now. - - (unless (slot-boundp-using-class class attribute property) - (slot-unbound class attribute (slot-definition-name property))) - - (let ((val (print (call-next-method)))) - - (if (and - ;; Not special access - (not (symbolp val)) - (contextl::slot-definition-layeredp property) - (not *bypass-property-layered-function*)) - (let ((fn val)) - ;(dprint "... using fn ~A to get value" fn) - (funcall fn layer (attribute-description attribute))) - val))) - -(defmacro define-bypass-function (name function-name) - `(defun ,name (&rest args) - (let ((*bypass-property-layered-function* t)) - (apply (function ,function-name) args)))) - -(define-bypass-function real-slot-boundp-using-class slot-boundp-using-class) -(define-bypass-function real-slot-value-using-class slot-value-using-class) -(define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class)) - -(defun slot-boundp-using-property-layered-function (class attribute property) - ;(dprint "plf boundp:") - (let* ((really-bound-p - (real-slot-boundp-using-class class attribute property)) - (fn (if really-bound-p - (real-slot-value-using-class class attribute property) - (setf (real-slot-value-using-class class attribute property) - (property-layered-function - (attribute-description attribute) - (attribute-name attribute) - (closer-mop:slot-definition-name property)))))) - - (if (generic-function-methods fn) - T - NIL))) - -(define-layered-method slot-boundp-using-layer - :in-layer (layer t) - :around (class (attribute standard-attribute) property reader) - (if (or *bypass-property-layered-function* *symbol-access*) - (call-next-method) - (slot-boundp-using-property-layered-function class attribute property))) - -(defun attribute-value* (attribute) - (attribute-value *object* attribute)) - -(defmacro with-attributes (names description &body body) - `(with-slots ,names ,description ,@body)) - -(defun display-attribute (attribute) - (display-using-description attribute *display* *object*)) - -(define-layered-method display-using-description - ((attribute standard-attribute) display object &rest args) - (declare (ignore args)) - (when (attribute-label attribute) - (format display "~A " (attribute-label attribute))) - (format display "~A" (attribute-value object attribute))) - - - - - - - - - - - +(in-package :lisp-on-lines) + +(define-layered-class direct-attribute-definition-class + (special-layered-direct-slot-definition + contextl::singleton-direct-slot-definition) + ((attribute-properties + :accessor direct-attribute-properties + :documentation "This is an plist to hold the values of + the attribute's properties as described by this direct + attribute definition."))) + +(defmethod initialize-instance + :after ((attribute direct-attribute-definition-class) + &rest initargs) + (setf (direct-attribute-properties attribute) initargs)) + +(define-layered-class effective-attribute-definition-class + (special-layered-effective-slot-definition) + ((direct-attributes + :accessor attribute-direct-attributes) + (attribute-object + :accessor attribute-object) + (attribute-object-initargs + :accessor attribute-object-initargs))) + +(defvar *function-access* nil + "set/get a place's property function instead of its symbol value + when this is set to a non-nil value") + +(defmacro with-function-access (&body body) + "executes body in an environment with *function-access* set to t" + `(let ((*function-access* t)) + ,@body)) + +(defmacro without-function-access (&body body) + "executes body in an environment with *function-access* set to nil" + `(let ((*function-access* nil)) + ,@body)) + +(define-layered-function property-access-function (description attribute-name property-name) + (:method (description attribute-name property-name) + (ensure-layered-function + (defining-description + (intern (format nil "~A-~A-~A" + (description-print-name description) + attribute-name + property-name))) + :lambda-list '(description)))) + + +(define-layered-class standard-attribute () + ((description-class :initarg description-class) + (name + :layered-accessor attribute-name + :initarg :name) + (effective-attribute-definition + :initarg effective-attribute + :accessor attribute-effective-attribute-definition) + (attribute-class + :accessor attribute-class + :initarg :attribute-class + :initform 'standard-attribute + :layered t) + (label + :layered-accessor attribute-label + :initarg :label + :initform nil + :layered t + :special t) + (function + :initarg :function + :layered-accessor attribute-function + :layered t + :special t) + (value + :layered-accessor %attribute-value + :initarg :value + :layered t + :special t) + (activep + :layered-accessor attribute-active-p + :initarg :activep + :initform t + :layered t + :special t) + (keyword + :layered-accessor attribute-keyword + :initarg :keyword + :initform nil + :layered t) +)) + +(defun ensure-access-function (class attribute property) + (with-function-access + (if (slot-definition-specialp property) + (let ((slot-symbol + (with-symbol-access + (slot-value-using-class + class attribute property)))) + (if (fboundp slot-symbol) + (symbol-function slot-symbol) + (setf (symbol-function slot-symbol) + (property-access-function + (attribute-description attribute) + (attribute-name attribute) + (slot-definition-name property))))) + (if (slot-boundp-using-class class attribute property) + (slot-value-using-class class attribute property) + (setf (slot-value-using-class class attribute property) + (property-access-function + (attribute-description attribute) + (attribute-name attribute) + (slot-definition-name property))))))) + +(define-layered-method slot-boundp-using-layer + :in-layer (layer t) + :around (class (attribute standard-attribute) property reader) + +; (dprint "Checking boundp ~A ~A" (attribute-name attribute) + ; (slot-definition-name property)) + + (if (or *symbol-access* *function-access*) + (call-next-method) + (or (when (slot-definition-specialp property) + (with-function-access + (slot-boundp-using-class class attribute property))) + (if (generic-function-methods + (ensure-access-function class attribute property)) + T + NIL)))) + +(define-layered-method (setf slot-value-using-layer) + :in-layer (context t) + :around + (new-value class (attribute standard-attribute) property writer) + +;; (dprint "Setting ~A ~A to : ~A" attribute property new-value) + + (if (or *symbol-access* *function-access*) + (call-next-method) + + (if (and (slot-definition-specialp property) + (with-function-access + (without-symbol-access (slot-boundp-using-class class attribute property)))) + (with-function-access + (call-next-method)) + (let ((layer + ;;FIXME: this is wrong for so many reasons + (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context)) + :key #'class-name)))) + (boundp (slot-boundp-using-class class attribute property)) + (fn (ensure-access-function class attribute property))) + + (when (not boundp) + ;; * This slot has never been set before. + ;; create a method on property-accessor-function + ;; so subclasses can see this new property. + (ensure-layered-method + (layered-function-definer 'property-access-function) + `(lambda (description attribute property) + (declare (ignore description attribute property)) + ,fn) + :in-layer layer + :specializers + (list (class-of + (attribute-description attribute)) + (closer-mop:intern-eql-specializer + (attribute-name attribute)) + (closer-mop:intern-eql-specializer + (closer-mop:slot-definition-name property))))) + + ;; specialize this property to this description. + ;;(dprint "actrually specializering") + (ensure-layered-method + fn + `(lambda (description) + (funcall ,(lambda() + new-value))) + :in-layer layer + :specializers (list (class-of (attribute-description attribute)))) + + ;; and return the set value as is custom + new-value)))) + +(define-layered-method slot-value-using-layer + :in-layer (layer t) + :around (class (attribute standard-attribute) property reader) + +; ;(dprint "Getting the slot value of ~A" property) + (if (or *symbol-access* *function-access*) + (call-next-method) + (let ((fn (ensure-access-function class attribute property))) + + (unless (slot-boundp-using-class class attribute property) + (slot-unbound class attribute (slot-definition-name property))) + + (if (slot-definition-specialp property) + (if (with-function-access + (slot-boundp-using-class class attribute property)) + (with-function-access + (slot-value-using-class class attribute property)) + (funcall fn layer (attribute-description attribute))) + (funcall fn layer (attribute-description attribute)))))) + + + + (define-layered-function attribute-value (object attribute)) + + (define-layered-method attribute-value (object attribute) + + (let ((fn (handler-case (attribute-function attribute) + (unbound-slot () nil)))) + (if fn + (funcall fn object) + (%attribute-value attribute)))) + +(defmethod attribute-description (attribute) + ;(break "description for ~A is (slot-value attribute 'description-name)") + (find-layer (slot-value attribute 'description-class)) + #+nil (let ((name (slot-value attribute 'description-name))) + (when name + (find-description name)))) + + + +(defmethod print-object ((object standard-attribute) stream) + (print-unreadable-object (object stream :type nil :identity t) + (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) + +(defgeneric eval-property-initarg (att initarg) + (:method ((attribute standard-attribute) initarg) + nil) + (:method ((attribute standard-attribute) (initarg (eql :function))) + t)) + +(defun prepare-initargs (att args) + (loop + :for (key arg) + :on args :by #'cddr + :nconc (list key + (if (eval-property-initarg att key) + (eval arg) + arg)))) + + +(defun attribute-value* (attribute) + (attribute-value *object* attribute)) + +(defmacro with-attributes (names description &body body) + `(with-slots ,names ,description ,@body)) + +(define-layered-function display-attribute (object attribute) + (:method (object attribute) + (display-using-description attribute *display* object))) + +(define-layered-function display-attribute-label (object attribute) + (:method (object attribute) + (format *display* "~A " (attribute-label attribute)) +)) + +(define-layered-function display-attribute-value (object attribute) + (:method (object attribute) + (let ((val (attribute-value object attribute))) + (if (eq val object) + (format *display* "~A " val) + (with-active-descriptions (inline) + (display *display* val ) + + ) + )))) + +(define-layered-method display-using-description + ((attribute standard-attribute) display object &rest args) + (declare (ignore args)) + (when (attribute-label attribute) + (display-attribute-label object attribute)) + (display-attribute-value object attribute)) + + + + + + + + + + + diff --git a/src/contextl-hacks.lisp b/src/contextl-hacks.lisp index ec78c35..ee4e38a 100644 --- a/src/contextl-hacks.lisp +++ b/src/contextl-hacks.lisp @@ -40,4 +40,25 @@ (list (find-class 'special-object))) initargs))) - (call-next-method)) \ No newline at end of file + (call-next-method)) + + + +(defun funcall-with-special-initargs (bindings thunk) + (let ((arg-count 0)) + (special-symbol-progv + (loop for (object . initargs) in bindings + for initarg-keys = (loop for key in initargs by #'cddr + collect key into keys + count t into count + finally (incf arg-count count) + (return keys)) + nconc (loop for slot in (class-slots (class-of object)) + when (and (slot-definition-specialp slot) + (intersection initarg-keys (slot-definition-initargs slot))) + collect (with-symbol-access + (slot-value object (slot-definition-name slot))))) + (make-list arg-count :initial-element nil) + (loop for (object . initargs) in bindings + do (apply #'shared-initialize object nil :allow-other-keys t initargs)) + (funcall thunk)))) \ No newline at end of file diff --git a/src/description-class.lisp b/src/description-class.lisp index 895c7ed..0669167 100644 --- a/src/description-class.lisp +++ b/src/description-class.lisp @@ -68,7 +68,8 @@ (superclass standard-class)) t) -(defclass standard-description-object (standard-layer-object) ()) +(defclass standard-description-object (standard-layer-object) + ()) (defun description-class-name (description-class) (read-from-string (symbol-name (class-name description-class)))) @@ -82,7 +83,7 @@ ;;; For now. --drewc (pushnew class *defined-descriptions*) - + ;;; ENDHACK. (let* ((description (find-layer class)) diff --git a/src/description.lisp b/src/description.lisp index c06a6f4..d19b92e 100644 --- a/src/description.lisp +++ b/src/description.lisp @@ -8,7 +8,8 @@ (description-class-name (class-of description))) (defun find-attribute (description attribute-name) - (slot-value description attribute-name)) + (when (slot-exists-p description attribute-name) + (slot-value description attribute-name))) (defun description-attributes (description) @@ -18,21 +19,34 @@ description) (class-slots (class-of description)))) -(defvar *display-attributes* nil) -(defun attribute-active-p (attribute) - (or (null *display-attributes*) - (find (attribute-name attribute) *display-attributes*))) + (define-layered-function attributes (description) (:method (description) - (remove-if-not - (lambda (attribute) - (and (attribute-active-p attribute) - (some #'layer-active-p - (mapcar #'find-layer - (slot-definition-layers - (attribute-effective-attribute-definition attribute)))))) - (description-attributes description)))) + (let* ((active-attributes + (find-attribute description 'active-attributes)) + (attributes (when active-attributes + (attribute-value *object* active-attributes)))) + (if attributes + (mapcar (lambda (spec) + (find-attribute + description + (if (listp spec) + (car spec) + spec))) + attributes) + (remove-if-not + (lambda (attribute) + (and (attribute-active-p attribute) + (some #'layer-active-p + (mapcar #'find-layer + (slot-definition-layers + (attribute-effective-attribute-definition attribute)))))) + (description-attributes description)))))) + + + + ;;; A handy macro. diff --git a/src/display.lisp b/src/display.lisp index 5888f0b..28957a9 100644 --- a/src/display.lisp +++ b/src/display.lisp @@ -2,7 +2,8 @@ (defvar *description*) (defvar *display*) -(defvar *object*) +(defvar *object* nil) + (deflayer display-layer) @@ -12,7 +13,7 @@ (defun display (display object &rest args &key attributes ) (let ((*display-attributes* attributes)) - (display-using-description (description-of object) display object args))) + (apply #'display-using-description (description-of object) display object args))) (define-layered-method display-using-description :around (description display object &rest args) @@ -20,20 +21,35 @@ (let ((*description* description) (*display* display) (*object* object)) - (call-next-method))) + (contextl::funcall-with-special-initargs + (loop + :for (key val) :on args :by #'cddr + :collect (list (find key (description-attributes description) + :key #'attribute-keyword) + :value val)) + (lambda () + (contextl::funcall-with-special-initargs + (let ((attribute (find-attribute description 'active-attributes))) + (when attribute + (loop for spec in (attribute-value object attribute) + if (listp spec) + collect (cons (or + (find-attribute description (car spec)) + (error "No attribute matching ~A" (car spec))) + (cdr spec))))) + (lambda () + (call-next-method))))))) + + (defun display/d (&rest args) (apply #'display-using-description args)) - - (define-layered-method display-using-description (description display object &rest args) (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~% DESCRIPTION: ~A ~% DISPLAY: ~A ~% OBJECT: ~A ~% ARGS: ~S OMGWTF! If you didn't do this, it's a bug!" description display object args)) - - (defmacro define-display (&body body) (loop with in-descriptionp = (eq (car body) :in-description) with description = (if in-descriptionp (cadr body) 't) diff --git a/src/packages.lisp b/src/packages.lisp index e65ff7c..2bca20d 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -3,13 +3,20 @@ :common-lisp #:contextl #:closer-mop + #:postmodern #:alexandria) (:nicknames #:lol) (:export - + +;; ROFL stuff here temporarily + #:standard-db-access-class + #:make-dao-from-row + #:described-db-access-class + ;; Descriptions #:find-description #:define-description + #:described-class #:with-active-descriptions ;; Displays diff --git a/src/rofl.lisp b/src/rofl.lisp new file mode 100644 index 0000000..48cc0cc --- /dev/null +++ b/src/rofl.lisp @@ -0,0 +1,223 @@ +(in-package :lisp-on-lines) + + +(defclass db-access-slot-definition () + ((column-name :initform nil :initarg :db-name :accessor slot-definition-column-name + :documentation + "If non-NIL, contains the name of the column this slot is representing.") + (primary-key :initform nil + :initarg :primary-key + :accessor slot-definition-primary-key-p) + (transient :initform nil :initarg :transient :accessor slot-definition-transient-p + :documentation + "If non-NIL, this slot should be treated as transient and +ignored in all database related operations.") + (not-null :initform nil :initarg :not-null :accessor slot-definition-not-null-p + :documentation "If non-NIL, a NON NULL database +constrained will be introduced.") + (foreign-type + :initform nil + :initarg :foreign-type + :initarg :references + :accessor slot-definition-foreign-type) + (unique :initform nil :initarg :unique :accessor slot-definition-unique) + + + (on-delete :initform :cascade :initarg :on-delete :accessor slot-definition-on-delete + :documentation "Action to be performed for this slot +when the refering row in the database ceases to exist. Possible +values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is +not a foreign key, it does nothing.") + (delayed-constraint :initform nil :accessor slot-definition-delayed-constraint + :documentation "Closures adding constraints +that, for some reason, could not be executed. If there's a slot with +this attribute not-NIL in a class definition, then there's something +wrong with its SQL counterpart."))) + +(defmethod slot-definition-column-name :around (slotd) + (or (call-next-method) (slot-definition-name slotd))) + + +(defclass db-access-class (standard-class) + ((table-name :initarg :table-name :initform nil :accessor class-table-name) + (indices :initarg :indices :initform () :reader class-indices) + (unique :initarg :unique :initform () :reader class-unique) + #+not!(connection-spec :initarg :connection-spec :initform nil :reader db-class-connection-spec) + + (unfinished-classes :initform nil :allocation :class :accessor class-unfinished-classes + :documentation "A class allocated slot +containing classes for whom not all the constraints could be +applied.") + (foreign-keys :initform nil :accessor class-foreign-keys + :documentation "List of foreign-key slots.") + (unique-keys :initform nil :accessor class-unique-keys + :documentation "List of slots whose value should be unique.")) + (:documentation "Metaclass for PostgreSQL aware classes. It takes +two additional arguments in DEFTABLE: :INDICES (which slots are used +as indices) and :CONNECTION-SPEC, which specifies how the class should +connect to the database (its format is the same as in +POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided, +SUBMARINE assumes it is a class created just for the sake of +inheritance and does not create any tables for it.")) + +(defmethod validate-superclass + ((class db-access-class) + (superclass standard-class)) + t) + + +(defclass db-access-direct-slot-definition (standard-direct-slot-definition + db-access-slot-definition) + ()) + +(defmethod direct-slot-definition-class + ((class db-access-class) &key &allow-other-keys) + (find-class 'db-access-direct-slot-definition)) + +(defclass db-access-effective-slot-definition + (standard-effective-slot-definition + db-access-slot-definition) + ()) + +(defmethod effective-slot-definition-class + ((class db-access-class) &key &allow-other-keys) + (find-class 'db-access-effective-slot-definition)) + +(defmethod compute-effective-slot-definition + ((class db-access-class) name direct-slot-definitions) + (declare (ignore name)) + (let ((slotd (call-next-method))) + (setf (slot-definition-primary-key-p slotd) + (some #'slot-definition-primary-key-p direct-slot-definitions) + (slot-definition-transient-p slotd) + (every #'slot-definition-transient-p direct-slot-definitions) + (slot-definition-foreign-type slotd) + (slot-definition-foreign-type (car direct-slot-definitions)) + (slot-definition-not-null-p slotd) + (slot-definition-not-null-p (car direct-slot-definitions)) + (slot-definition-unique slotd) (slot-definition-unique (car direct-slot-definitions)) + (slot-definition-type slotd) (slot-definition-type (car direct-slot-definitions))) + slotd)) + +(defun class-id-slot-definition (class) + (find-if #'slot-definition-primary-key-p + (class-slots class))) + +(defmethod class-table-name :around (class) + (or (call-next-method) + (class-name class))) + +(defclass standard-db-access-class (db-access-class) + ()) + +(defun dao-id-column-name (class) + (slot-definition-column-name + (or (class-id-slot-definition class) + (error "No ID slot (primary key) for ~A" class)))) + +(defclass described-db-access-class (standard-db-access-class described-class) + ()) + +(defmethod initialize-instance :around ((class standard-db-access-class) &rest initargs &key (direct-superclasses '())) + (declare (dynamic-extent initargs)) + (if (loop for direct-superclass in direct-superclasses + thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object))) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses + (append direct-superclasses + (list (find-class 'standard-db-access-object))) + initargs))) + +(defmethod reinitialize-instance :around ((class standard-db-access-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) + (declare (dynamic-extent initargs)) + (if (or (not direct-superclasses-p) + (loop for direct-superclass in direct-superclasses + thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object)))) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses + (append direct-superclasses + (list (find-class 'standard-db-access-object))) + initargs))) + +(defclass standard-db-access-object (standard-object) + ()) + + + +(defun find-dao (type id + &key (table (class-table-name (find-class type))) + id-column-name) + + "Get the dao corresponding to the given primary key, +or return nil if it does not exist." + (let ((row (first (query + (:select '* + :from table + :where (:= id (or id-column-name + (dao-id-column-name + (find-class type))))))))) + (make-dao-from-row type row))) + +(defmethod shared-initialize :after ((dao standard-db-access-object) + slots &rest initargs) + (let ((class (class-of dao))) + (dolist (slotd (class-slots class)) + (with-slots (foreign-type) slotd + (when foreign-type + (if (slot-boundp-using-class class dao slotd) + (let ((value (slot-value-using-class class dao slotd))) + (unless (typep value foreign-type) + (if (connected-p *database*) + (setf (slot-value-using-class class dao slotd) + (find-dao foreign-type value)) + (let ((obj (make-instance foreign-type))) + (setf (slot-value-using-class + (class-of obj) + obj + (class-id-slot-definition (class-of obj))) + value))))))))))) + +(defgeneric dao-id (dao) + (:method ((dao standard-db-access-object)) + (let ((class (class-of dao))) + + (slot-value-using-class class dao (class-id-slot-definition class))))) + +(defun make-dao-from-row (type row &key slots) + (let* ((class (find-class type)) + (dao (make-instance class)) + (slotds (class-slots class))) + (loop + :for val :in row + :for slotd + :in (or + (loop + :for slot :in slots + :collect (find slot slotds + :key #'slot-definition-name)) + slotds) + :do (setf (slot-value-using-class class dao slotd) val) + :finally (return (reinitialize-instance dao))))) + +;(defgeneric make-dao (type &rest initargs) +#+nil(defun make-dao (type initargs) + "Create a DAO of the given `TYPE' and initialize it according + to the values of the alist `INITARGS'. `Initargs' may contain + additional values, not used in the initialization proccess." + (let ((instance (make-instance type))) + (iter (for slot in (slots-of instance)) + (setf (slot-value instance (slot-definition-name slot)) + (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot)) 'keyword) initargs)))) + (if (foreign-type-p slot) + (make-instance (sb-pcl:slot-definition-type slot) :id the-value) + the-value)))) + instance)) + + + + + diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp index 2824c2e..8531b22 100644 --- a/src/standard-descriptions/clos.lisp +++ b/src/standard-descriptions/clos.lisp @@ -1,32 +1,80 @@ (in-package :lisp-on-lines) +(defstruct unbound-slot-value (s)) + +(defvar +unbound-slot+ (make-unbound-slot-value)) + +(defmethod print-object ((object unbound-slot-value) stream) + (print-unreadable-object (object stream) + (format stream "UNBOUND"))) + (define-description standard-object () - ((class-slots :label "Slots" + ((editp :value t) + (class-slots :label "Slots" :function (compose 'class-slots 'class-of)))) (define-layered-class slot-definition-attribute (standard-attribute) ((slot-name :initarg :slot-name :accessor attribute-slot-name))) +(defmethod shared-initialize :around ((object slot-definition-attribute) + slots &rest args) + (prog1 (call-next-method) + (unless (attribute-setter object) + (setf (attribute-setter object) + (lambda (v o) + (setf (slot-value o (attribute-slot-name object)) v)))))) + + (define-layered-method attribute-value (object (attribute slot-definition-attribute)) (if (slot-boundp object (attribute-slot-name attribute)) (slot-value object (attribute-slot-name attribute)) (gensym "UNBOUND-SLOT-"))) -(defmacro define-description-for-class (class-name &optional (name (intern (format nil "DESCRIPTION-FOR-~A" class-name)))) - `(progn - (define-description ,name (standard-object) - ,(loop :for slot in (class-slots (find-class class-name)) - :collect `(,(slot-definition-name slot) - :attribute-class slot-definition-attribute - :slot-name ,(slot-definition-name slot) - :label ,(slot-definition-name slot))) - (:mixinp t)) - (unless (ignore-errors (find-description ',class-name)) - (define-description ,class-name (,name) ())))) +(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))) + (let ((desc-class + (ensure-class (defining-description name) + :direct-superclasses (list (class-of (find-description 'standard-object))) + :direct-slots (loop :for slot in (class-slots class) + :collect `(:name ,(slot-definition-name slot) + :attribute-class slot-definition-attribute + :slot-name ,(slot-definition-name slot) + :label ,(slot-definition-name slot)) + :into slots + :collect (slot-definition-name slot) :into names + :finally (return (cons `(:name active-attributes + :value ,names) + slots))) + :metaclass 'standard-description-class))) - - + (unless (ignore-errors (find-description (class-name class))) + (ensure-class (defining-description (class-name class)) + :direct-superclasses (list desc-class) + :metaclass 'standard-description-class)) + (find-description name))) + +(defclass described-class () + ()) + +(defmethod validate-superclass + ((class described-class) + (superclass standard-class)) + t) + +(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '())) + (declare (dynamic-extent initargs)) + (finalize-inheritance class) + (ensure-description-for-class class)) + + +(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) + (declare (dynamic-extent initargs)) + (finalize-inheritance class) + (ensure-description-for-class class)) + + + + (define-layered-method description-of ((object standard-object)) (or (ignore-errors (find-description (class-name (class-of object)))) (find-description 'standard-object))) diff --git a/src/standard-descriptions/inline.lisp b/src/standard-descriptions/inline.lisp new file mode 100644 index 0000000..9d05b65 --- /dev/null +++ b/src/standard-descriptions/inline.lisp @@ -0,0 +1,16 @@ +(in-package :lisp-on-lines) + +(define-description inline ()) + +(define-description t () + ((identity :label nil) + (active-attributes :value (identity))) + (:in-description inline)) + +(define-display :in-description inline ((description t)) + (format *display* "~{~A ~}" + (mapcar + (lambda (attribute) + (with-output-to-string (*display*) + (display-attribute *object* attribute))) + (attributes description)))) diff --git a/src/standard-descriptions/symbol.lisp b/src/standard-descriptions/symbol.lisp index 300b481..c811d07 100644 --- a/src/standard-descriptions/symbol.lisp +++ b/src/standard-descriptions/symbol.lisp @@ -4,7 +4,7 @@ (find-description 'symbol)) (define-description symbol () - ((identity :label "Symbol:") + ((identity :label nil) (name :function #'symbol-name :label "Name:") diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp index fe4864f..2980e31 100644 --- a/src/standard-descriptions/t.lisp +++ b/src/standard-descriptions/t.lisp @@ -3,7 +3,11 @@ (define-description T () ((identity :label nil :function #'identity) (type :label "Type" :function #'type-of) - (class :label "Class" :function #'class-of))) + (class :label "Class" :function #'class-of) + (active-attributes :label "Attributes" + :value nil + :activep nil + :keyword :attributes))) (define-layered-method description-of (any-lisp-object) (find-description 't)) @@ -13,6 +17,8 @@ (mapcar (lambda (attribute) (with-output-to-string (*display*) - (display-attribute attribute))) + (display-attribute *object* attribute))) (attributes description)))) + + diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp index a77c24a..57c8125 100644 --- a/src/ucw/html-description.lisp +++ b/src/ucw/html-description.lisp @@ -7,11 +7,12 @@ (define-description t () - ((css-class :value "lol-description") + ((css-class :value "lol-description" :activep nil) (dom-id :function (lambda (x) (declare (ignore x)) (symbol-name - (gensym "DOM-ID-"))))) + (gensym "DOM-ID-"))) + :activep nil)) (:in-description html-description)) (define-layered-class html-attribute () @@ -24,50 +25,110 @@ (html-attribute) ()) -(define-display - :in-description html-description ((description t)) - (with-attributes (css-class dom-id) description - (<:style - (<:as-html " +(define-layered-function display-html-attribute-label (object attribute) + (:method (object attribute) + (let ((label (attribute-label attribute))) + (<:label + :class "lol-attribute-label" + (when label + (<:as-html + (with-output-to-string (*display*) + (display-attribute-label object attribute)))))))) + +(define-layered-function display-html-attribute-value (object attribute) + (:method (object attribute) + (<:span + :class "lol-attribute-value" + (<:as-html (with-output-to-string (*display*) + (display-attribute-value object attribute)))) +)) + +(define-layered-function display-html-attribute (object attribute) + (:method (object attribute) + (<:div + :class (attribute-css-class attribute) + (when (attribute-dom-id attribute) + :id (attribute-dom-id attribute)) + (display-html-attribute-label object attribute) + (display-html-attribute-value object attribute) + (<:br))) + (:method :in-layer #.(defining-description 'inline) + (object attribute) + (<:span + :class (attribute-css-class attribute) + (when (attribute-dom-id attribute) + :id (attribute-dom-id attribute)) + (display-html-attribute-label object attribute) + (<:as-html " ") + (display-html-attribute-value object attribute) + (<:as-html " ")))) + +(define-layered-method display-html-attribute-value + :in-layer #.(defining-description 'editable) (object attribute) + + (<:span + :class "lol-attribute-value" + (if (attribute-editp object attribute) + (