:components ((:file "contextl-hacks")
(:file "packages")
+ (:file "rofl")
(:file "utilities")
(:file "display")
(:module :standard-descriptions
:components ((:file "t")
+ (:file "inline")
(:file "edit")
(:file "symbol")
(:file "list")
:serial t))
:serial t
- :depends-on (:contextl :arnesi :alexandria))
+ :depends-on (:contextl :arnesi :alexandria :postmodern))
-(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))
+
+
+
+
+
+
+
+
+
+
+
(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
(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))))
;;; For now. --drewc
(pushnew class *defined-descriptions*)
-
+
;;; ENDHACK.
(let* ((description (find-layer class))
(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)
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.
(defvar *description*)
(defvar *display*)
-(defvar *object*)
+(defvar *object* nil)
+
(deflayer display-layer)
(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)
(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)
: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
--- /dev/null
+(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))
+
+
+
+
+
(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)))
--- /dev/null
+(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))))
(find-description 'symbol))
(define-description symbol ()
- ((identity :label "Symbol:")
+ ((identity :label nil)
(name
:function #'symbol-name
:label "Name:")
(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))
(mapcar
(lambda (attribute)
(with-output-to-string (*display*)
- (display-attribute attribute)))
+ (display-attribute *object* attribute)))
(attributes description))))
+
+
(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 ()
(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)
+ (<lol:input :reader (attribute-value object attribute)
+ :writer (lambda (val)
+ (setf (attribute-value object attribute) val)))
+ (call-next-method))
+))
+
+(define-layered-function display-html-description (description display object)
+ (:method (description display object)
+ (<:style
+ (<:as-html "
-.lol-attribute-label, .lol-attribute-value {
+div.lol-description .lol-attribute-label,
+div.lol-description .lol-attribute-value {
display: block;
- width: 70%;
+ width: 69%;
float: left;
- margin-bottom: 10px;
+ margin-bottom: 1em;
}
+div.lol-description
.lol-attribute-label {
text-align: right;
width: 24%;
padding-right: 20px;
}
-.lol-attribute-value {
-
- }
+div.lol-description
br {
clear: left;
}"))
+
+ (with-attributes (css-class dom-id) description
+
- (<:div
- :class (list (attribute-value* css-class) "lol-description")
- :id (attribute-value* dom-id)
- (dolist (attribute (attributes description))
(<:div
- :class (attribute-css-class attribute)
- (when (attribute-dom-id attribute)
- :id (attribute-dom-id attribute))
- (let ((label (attribute-label attribute)))
- (when label
- (<:label
- :class "lol-attribute-label"
- (<:as-html label))))
- (<:span
- :class "lol-attribute-value"
- (<:as-html (format nil "~A" (attribute-value* attribute))))
- (<:br))))))
+ :class (list (attribute-value* css-class) "lol-description" "t")
+ :id (attribute-value* dom-id)
+ (unless *object* (error "Object is nil .. why?"))
+ (dolist (attribute (attributes description))
+ (display-html-attribute *object* attribute))))))
+
+
+(define-layered-method display-html-description
+ :in-layer #.(defining-description 'inline) (description display object)
+
+ (with-attributes (css-class dom-id) description
+
+
+ (<:span
+ :class (list (attribute-value* css-class) "lol-description")
+ :id (attribute-value* dom-id)
+ (unless *object* (error "Object is nil .. why?"))
+ (dolist (attribute (attributes description))
+ (display-html-attribute *object* attribute))))
+ )
+
+(define-display
+ :in-description html-description ((description t) (display lol-ucw:component) object )
+ (display-html-description description display object))
#:shutdown-server
+ ;; Sessions
+ #:get-session-value
;; Standard Application
#:standard-application
#:register-application
;; Standard Components
#:render
+ #:render-html-body
#:component
+
#:standard-component-class
+ #:described-component-class
+
+ #:container
+ #:find-component
#:standard-window-component ;*
#:window-body
(in-package :lisp-on-lines-ucw)
+(defclass described-component-class (standard-component-class described-class)
+ ())
+
(defmacro defaction (&rest args-and-body)
`(arnesi:defmethod/cc ,@args-and-body))
:component t
:initarg :body)))
-(defmethod ucw:render-html-body ((window standard-window-component))
+(defmethod render-html-body ((window standard-window-component))
(ucw:render (window-body window)))