:components ((:static-file "lisp-on-lines.asd")
(:module :src
- :components ((:file "contextl-hacks")
+ :components (#-lol-mao(:file "contextl-hacks")
(:file "packages")
(:file "utilities")
- (:file "display")
- (:file "attribute")
-
- (:file "description-class")
- (:file "description")
-
-
+ #+lol-mao
+ (:module :mao
+ :components ((:file "simple-plist-attribute")
+ (:file "attribute")
+ (:file "description-class")
+ (:file "description")
+ (:module :display
+ :components ((:file "display-attribute")
+ (:file "display-description")
+ (:file "define-description-compat"))
+ :serial t))
+ :serial t)
+ (:file "display")
+ #-lol-mao(:file "attribute")
+ #-lol-mao(:file "description-class")
+ #-lol-mao(:file "description")
(:module :standard-descriptions
:components ((:file "t")
((attribute-1 :value "VALUE")
(attribute-2 :function (constantly "VALUE"))))
- (deflayer attribute-test)
+ (define-description attribute-test)
(define-description attribute-test-description ()
((attribute-1 :value "VALUE2")
(attribute-2 :function (constantly "VALUE2")))
- (:in-layer . attribute-test))))
-
- (let ((d (find-description 'attribute-test-description)))
- (dletf (((described-object d) nil))
- (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
-
- (with-active-layers (attribute-test)
- (is (equalp (attribute-value (find-attribute d 'attribute-1))
- (attribute-value (find-attribute d 'attribute-2))))
- (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))))
+ (:in-description attribute-test))))
+
+ (funcall-with-described-object
+ (lambda (&aux
+ (a1 (find-attribute *description* 'attribute-1))
+ (a2 (find-attribute *description* 'attribute-2))
+ )
+ (is (equalp "VALUE" (attribute-value a1)))
+ (is (equalp "VALUE" (attribute-value a2)))
+ (with-active-descriptions (attribute-test)
+ (is (equalp "VALUE2" (attribute-value a1)))
+ (is (equalp "VALUE2" (attribute-value a2)))))
+ nil
+ (find-description 'attribute-test-description)))
(deftest test-attribute-property-inheriting ()
(test-attribute-value)
(eval '(progn
- (deflayer attribute-property-test)
+ (define-description attribute-property-test)
(define-description attribute-test-description ()
((attribute-1 :label "attribute1")
(attribute-2 :label "attribute2"))
- (:in-layer . attribute-property-test))))
- (with-active-layers (attribute-property-test)
- (let ((d (find-description 'attribute-test-description)))
- (dletf (((described-object d) nil))
-
- (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
+ (:in-description attribute-property-test))))
+
+ (with-active-descriptions (attribute-property-test)
+ (with-described-object (nil (find-description 'attribute-test-description))
+ (let ((d (dynamic description)))
+ (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
(is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
(is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
- (with-active-layers (attribute-test)
+ (with-active-descriptions (attribute-test)
(is (equalp (attribute-value (find-attribute d 'attribute-1))
(attribute-value (find-attribute d 'attribute-2))))
- (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))))
+ (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))
+))
(deftest (test-attribute-with-different-class :compile-before-run t) ()
(eval '(progn
(define-layered-class
- test-attribute-class (lol::standard-attribute)
- ((some-slot :initarg :some-slot
- :layered t
- :layered-accessor some-slot)))
+ test-attribute-class (standard-attribute)
+ ((some-slot :initarg :some-slot
+ :layered t
+ :special t
+ :layered-accessor some-slot)))
(define-description test-attribute-with-different-class-description ()
((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))
(apply #'display-using-description (description-of object) display object args))))
(define-layered-method display-using-description
- :around (description display object &rest args)
+ :around ((description standard-description-object) display object &rest args)
(declare (ignorable args))
#+nil (break "Entering DISPLAY for ~A on ~A using ~A" object display description)
(let ((*display* display))
+
(defun display/d (&rest args)
(apply #'display-using-description args))
(list (first description-spec)
(if (eq 'description (second description-spec))
'description
- (defining-description (second description-spec)))))
+ (contextl::defining-layer (defining-description (second description-spec))))))
,display-spec
,object-spec &rest args)
(declare (ignorable args))
(in-package :lisp-on-lines)
+;;;; A simpler implementation of descriptions based on plists
+
(setf (find-class 'simple-attribute nil) nil)
(define-layered-class simple-attribute ()
((%property-access-function
- :initarg property-access-function)))
+ :initarg property-access-function)
+ (%initial-slot-values-plist)))
(defun ensure-property-access-function (attribute)
(if (slot-boundp attribute '%property-access-function)
(define-layered-method
contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader)
- (if (or *symbol-access*
- (eq (slot-definition-name slotd)
- '%property-access-function)
+ (if (or contextl:*symbol-access*
(not (slot-definition-layeredp slotd)))
(call-next-method)
(let ((value (getf (funcall (ensure-property-access-function attribute))
(call-next-method)
value))))
-(defvar *test-attribute-definitions*
- `((t :label "foo" :value "foo")
- (simple-test-layer :label "BAZ" :value "BAZ")))
+(define-layered-method
+ contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader)
+ (if (or contextl:*symbol-access*
+ (not (slot-definition-layeredp slotd))
+ (dynamic-symbol-boundp (with-symbol-access (call-next-method))))
+ (call-next-method)
+ (let ((value (getf (ignore-errors (funcall (ensure-property-access-function attribute)))
+ (slot-definition-name slotd)
+ +property-not-found+)))
+ (if (eq value +property-not-found+)
+ (let ((value (get (ensure-property-access-function attribute)
+ (slot-definition-name slotd)
+ +property-not-found+)))
+ (if (eq value +property-not-found+)
+ (call-next-method)
+ value))
+ value))))
+
+(define-layered-method
+ (setf contextl:slot-value-using-layer) (value class (attribute simple-attribute) slotd reader)
+ (if (and (not contextl:*symbol-access*)
+ (slot-definition-layeredp slotd))
+ (setf (get (ensure-property-access-function attribute) (slot-definition-name slotd))
+ value)
+ (call-next-method)))
(defmethod initialize-attribute-for-layer (attribute layer-name &rest args)
(let* ((class (class-of attribute))
- (slotds (class-slots class)))
-
+ (slotds (class-slots class)))
(ensure-layered-method
(ensure-property-access-function attribute)
`(lambda ()
',(loop
- :for (key val) :on args :by #'cddr
- :nconc (list
- (loop :for slotd :in slotds
- :do (when (find key (slot-definition-initargs slotd))
- (return (slot-definition-name slotd))))
- val)))
+ :for (key val) :on args :by #'cddr
+ :nconc (list
+ (loop
+ :for slotd :in slotds
+ :do (when (find key (slot-definition-initargs slotd))
+ (return (slot-definition-name slotd))))
+ val)))
:qualifiers '(append)
:in-layer layer-name)))
-
-(define-layered-class simple-standard-attribute (simple-attribute)
- ((label
- :layered-accessor attribute-label
- :initarg :label
- :initform nil
- :layered t
- :special t)
- (label-formatter
- :layered-accessor attribute-label-formatter
- :initarg :label-formatter
- :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)
- (value-formatter
- :layered-accessor attribute-value-formatter
- :initarg :value-formatter
- :initform nil
- :layered t
- :special t)
- (activep
- :layered-accessor attribute-active-p
- :initarg :active
- :initform t
- :layered t
- :special t
- :documentation
- "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
- (active-attributes :layered-accessor attribute-active-attributes
- :initarg :attributes
- :layered t
- :special t)
- (active-descriptions :layered-accessor attribute-active-descriptions
- :initarg :activate
- :initform nil
- :layered t
- :special t)
- (inactive-descriptions :layered-accessor attribute-inactive-descriptions
- :initarg :deactivate
- :initform nil
- :layered t
- :special t)))
-
-
(define-layered-class direct-attribute-slot-definition-class
(special-layered-direct-slot-definition
contextl::singleton-direct-slot-definition)
((class description-access-class) &key &allow-other-keys)
(find-class 'effective-attribute-slot-definition-class))
(fmakunbound 'initialize-slot-definition-attribute)
+
(defmethod initialize-slot-definition-attribute ((slotd effective-attribute-slot-definition-class) name direct-slot-definitions)
(let ((tbl (make-hash-table))
(attribute (make-instance 'simple-standard-attribute :name name)))
- (loop for ds in direct-slot-definitions
+ (loop for ds in direct-slot-definitions
+ :when (typep ds 'direct-attribute-slot-definition-class)
:do (setf (gethash (slot-definition-layer ds) tbl)
(append (gethash (slot-definition-layer ds) tbl '())
(slot-definition-attribute-properties ds))))
((class description-access-class) name direct-slot-definitions)
(declare (ignore name))
(let ((slotd (call-next-method)))
- (initialize-slot-definition-attribute slotd)
+ (initialize-slot-definition-attribute slotd name direct-slot-definitions)
slotd))
(defclass standard-description-class (description-access-class layered-class)
((described-object :accessor described-object
:special t)))
-(defun initialize-description-class-attribute (description attribute initargs)
- )
-
(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
(declare (dynamic-extent initargs))
(prog1
:direct-superclasses
(append direct-superclasses
(list (find-class 'standard-description-object)))
- initargs))
- (break "initializing ~A ~A" class initargs)))
+ initargs))))
(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
:direct-superclasses
(append direct-superclasses
(list (find-class 'standard-description-object)))
- initargs))
- (break "RE-initializing ~A ~A" class initargs)))
+ initargs))))
+
+
-(defmethod finalize-inheritance :after ((class standard-description-class))
- (break "Finalizing ~S" (class-name class)))
-;;;; A simpler implementation of descriptions based on plists
;; Descriptions
#:*description*
+ #:description
+ #:defdescription
#:find-description
+ #:current-description
#:description-of
#:define-description
#:defining-description
#:described-object
#:with-described-object
+ #:funcall-with-described-object
#:described-class
#:described-standard-class
#:with-active-descriptions
(class-slots :label "Slots"
:function (compose 'class-slots 'class-of))))
-(define-layered-class slot-definition-attribute (standard-attribute)
+(define-description standard-object ()
+ ((editp :value t)
+ (class-slots :label "Slots"
+ :function (compose 'class-slots 'class-of)))
+ (:in-description editable))
+
+(define-layered-class slot-definition-attribute (define-description-attribute)
((slot-name :initarg :slot-name
:accessor attribute-slot-name
:layered t)))
(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))))))
+ (with-active-descriptions (editable)
+ (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-using-object (object (attribute slot-definition-attribute))
(delete nil (mapcar (rcurry #'find-description nil)
(mapcar #'class-name direct-superclasses)))))
(desc-class
- (ensure-class (defining-description name)
+ (ensure-layer (defining-description name)
:direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
:direct-slots
(loop
:finally (return (cons `(:name active-attributes
:value ',(or attributes names))
slots)))
- :metaclass 'standard-description-class)))
+ :metaclass 'define-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)))
+ (find-layer (ensure-layer (defining-description (class-name class))
+ :direct-superclasses (list desc-class)
+ :metaclass 'define-description-class)))))
(defclass described-class ()
()
(:mixinp t))
-(define-layered-class standard-attribute
+(define-layered-class define-description-attribute
:in-layer #.(defining-description 'editable)
()
((edit-attribute-p
:initform :inherit
:layered-accessor attribute-editp
:initarg :editp
- :layered t)
+ :layered t
+ :special t)
(setter
:initarg :setter
:layered t
- :accessor attribute-setter
+ :layered-accessor attribute-setter
:initform nil)
(attribute-editor
:initarg :editor
:initform (make-instance 'attribute-editor)
:documentation "This ones a bit odd")))
+(define-layered-method attribute-setter (object)
+ nil)
+
(defmethod shared-initialize :after ((object standard-attribute)
slots &rest args &key input &allow-other-keys)
:in-layer #.(defining-description 'editable)
((attribute standard-attribute))
(let ((value (attribute-value attribute)))
- (unless (or (unbound-slot-value-p value)
- (typep value
+ (unless (or (unbound-slot-value-p value)
+ (typep value
(attribute-editor-type
(attribute-editor attribute))))
- (return-from attribute-editp nil)))
+ (return-from attribute-editp nil)))
(let ((edit? (call-next-method)))
+
(if (eq :inherit edit?)
(attribute-value (find-attribute
(attribute-description attribute)
(in-package :lisp-on-lines)
-(define-layered-class list-attribute (standard-attribute)
+(define-layered-class list-attribute (define-description-attribute)
((item-args :initform nil :initarg :item :layered t :special t)))
(define-layered-method display-attribute-value
())
(define-layered-method description-of ((object null))
- (find-description 'null))
\ No newline at end of file
+ (find-description 'null))
(in-package :lisp-on-lines)
-(defclass #.(defining-description 'validate) ()
- ((invalid-object-condition-map :layered t :special t ))
- (:metaclass standard-description-class))
+(define-description validate ()
+ ((invalid-object-condition-map :layered t :special t )))
(define-layered-class standard-attribute
:in-layer #.(defining-description 'validate)
(define-layered-method display-using-description
:in-layer #.(defining-description 'html-description)
:around ((attribute standard-attribute) display object &rest args)
- (declare (ignore args))
+ (declare (ignore args))
(display-html-attribute object attribute))
(apply function args)))))
(defun make-attribute-value-writer (attribute)
- (let ((obj (described-object (attribute-description attribute)))
- (value (attribute-value attribute)))
+ (let ((obj (described-object (attribute-description attribute)))
+ (value (attribute-value attribute))
+ (desc (attribute-description attribute)))
(lambda (val)
- (dletf (((described-object attribute) obj))
+ (dletf (((described-object (attribute-description attribute)) obj))
(with-active-descriptions (editable)
(unless (and (unbound-slot-value-p value)
(equal "" val))
- (setf (attribute-value attribute)
- (parse-attribute-value attribute val))))))))
+ (with-described-object (obj desc)
+ (setf (attribute-value attribute)
+ (parse-attribute-value attribute val)))))))))
(defmethod html-attribute-value (attribute)
:reader (html-attribute-value attribute)
:writer (make-attribute-value-writer attribute)))
-
-
-
(define-layered-method display-attribute-editor
:in-layer #.(defining-description 'html-description) (attribute)
(display-html-attribute-editor attribute (attribute-editor attribute)))
(define-layered-method display-html-attribute-value
:in-layer #.(defining-description 'editable) (object attribute)
-
+ (<:as-html (princ-to-string (attribute-editp attribute)))
(if (attribute-editp attribute)
(<:td
- :class "lol-attribute-value"(display-attribute-editor attribute))
+ :class "lol-attribute-value" (display-attribute-editor attribute))
(call-next-method)))
(define-layered-function display-html-description (description display object &optional next-method)
(:method (description display object &optional (next-method #'display-using-description))
-
-
- (with-attributes (css-class dom-id) description
-
-
- (<:table
+ (let ((dom-id (find-attribute description 'dom-id))
+ (css-class (find-attribute description 'dom-id)))
+ (<:table
:class (list (attribute-value css-class) "lol-description" "t")
:id (attribute-value dom-id)
(funcall next-method)
(define-layered-method display-html-description
:in-layer #.(defining-description 'inline) (description display object &optional next-method)
- (with-attributes (css-class dom-id) description
+ (let ((dom-id (find-attribute description 'dom-id))
+ (css-class (find-attribute description 'dom-id)))
(<:span
- :class (list (attribute-value css-class) "lol-description")
- :id (attribute-value dom-id)
- (funcall next-method))))
+ :class (list (attribute-value css-class) "lol-description")
+ :id (attribute-value dom-id)
+ (funcall next-method))))
(define-display
HCoop / clinton / lisp-on-lines.git / commitdiff