From 4358148e6c67fcc2ae24050c54d8050b4dc03f9d Mon Sep 17 00:00:00 2001 From: drewc Date: Fri, 11 Jan 2008 10:50:16 -0800 Subject: [PATCH] Added standard descriptions and UCW integration. Checkpoint: Tests pass. ***END OF DESCRIPTION*** Place the long patch description above the ***END OF DESCRIPTION*** marker. The first line of this file will be the patch name. This patch contains the following changes: A ./lisp-on-lines-ucw.asd M ./lisp-on-lines.asd -10 +39 M ./src/attribute-test.lisp -6 +27 M ./src/attribute.lisp -58 +198 A ./src/contextl-hacks.lisp M ./src/description-class.lisp -101 +143 M ./src/description-test.lisp -6 M ./src/description.lisp -42 +57 M ./src/display-test.lisp -13 +12 M ./src/display.lisp -10 +19 M ./src/packages-test.lisp -1 +1 M ./src/packages.lisp -2 +7 A ./src/standard-descriptions/ A ./src/standard-descriptions/clos.lisp A ./src/standard-descriptions/edit.lisp A ./src/standard-descriptions/list.lisp A ./src/standard-descriptions/symbol.lisp A ./src/standard-descriptions/t.lisp A ./src/ucw/ A ./src/ucw/html-description.lisp A ./src/ucw/lol-tags-test.lisp A ./src/ucw/lol-tags.lisp A ./src/ucw/packages.lisp A ./src/ucw/standard-components.lisp A ./src/ucw/ucw-test.lisp M ./src/utilities.lisp -10 +19 darcs-hash:20080111185016-39164-73d0df2c35cc111cb862c3abb71e8b132f78d5d1.gz --- lisp-on-lines-ucw.asd | 21 ++ lisp-on-lines.asd | 49 +++- src/attribute-test.lisp | 33 ++- src/attribute.lisp | 316 +++++++++++++++++++------- src/contextl-hacks.lisp | 43 ++++ src/description-class.lisp | 286 +++++++++++++---------- src/description-test.lisp | 6 - src/description.lisp | 145 ++++++------ src/display-test.lisp | 41 ++-- src/display.lisp | 29 ++- src/packages-test.lisp | 2 +- src/packages.lisp | 9 +- src/standard-descriptions/clos.lisp | 13 ++ src/standard-descriptions/edit.lisp | 60 +++++ src/standard-descriptions/list.lisp | 20 ++ src/standard-descriptions/symbol.lisp | 25 ++ src/standard-descriptions/t.lisp | 18 ++ src/ucw/html-description.lisp | 50 ++++ src/ucw/lol-tags-test.lisp | 3 + src/ucw/lol-tags.lisp | 99 ++++++++ src/ucw/packages.lisp | 101 ++++++++ src/ucw/standard-components.lisp | 46 ++++ src/ucw/ucw-test.lisp | 161 +++++++++++++ src/utilities.lisp | 29 ++- 24 files changed, 1264 insertions(+), 341 deletions(-) create mode 100644 lisp-on-lines-ucw.asd rewrite src/attribute.lisp (82%) create mode 100644 src/contextl-hacks.lisp rewrite src/description-class.lisp (96%) rewrite src/description.lisp (89%) rewrite src/display-test.lisp (90%) create mode 100644 src/standard-descriptions/clos.lisp create mode 100644 src/standard-descriptions/edit.lisp create mode 100644 src/standard-descriptions/list.lisp create mode 100644 src/standard-descriptions/symbol.lisp create mode 100644 src/standard-descriptions/t.lisp create mode 100644 src/ucw/html-description.lisp create mode 100644 src/ucw/lol-tags-test.lisp create mode 100644 src/ucw/lol-tags.lisp create mode 100644 src/ucw/packages.lisp create mode 100644 src/ucw/standard-components.lisp create mode 100644 src/ucw/ucw-test.lisp diff --git a/lisp-on-lines-ucw.asd b/lisp-on-lines-ucw.asd new file mode 100644 index 0000000..6ea3a12 --- /dev/null +++ b/lisp-on-lines-ucw.asd @@ -0,0 +1,21 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package :coop.tech.systems) + (defpackage :coop.tech.systems + (:documentation "ASDF System package for meta-model.") + (:use :common-lisp :asdf)))) + +(in-package :coop.tech.systems) + +(defsystem :lisp-on-lines-ucw + :components ((:module :src + :components + ((:module :ucw + :components ((:file "packages") + (:file "standard-components") + (:file "lol-tags")) + + :serial t)))) + :serial t + + + :depends-on (:lisp-on-lines :ucw :puri)) \ No newline at end of file diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index 993a672..fcb4394 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -3,14 +3,14 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package :coop.tech.systems) (defpackage :coop.tech.systems - (:documentation "ASDF System package for meta-model.") + (:documentation "ASDF System package for Lisp On Lines") (:use :common-lisp :asdf)))) (in-package :coop.tech.systems) (defsystem :lisp-on-lines :license -"Copyright (c) 2004-2007 Drew Crampsie + "Copyright (c) 2004-2007 Drew Crampsie Contains portions of ContextL: Copyright (c) 2005 - 2007 Pascal Costanza @@ -38,26 +38,55 @@ OTHER DEALINGS IN THE SOFTWARE." :components ((:static-file "lisp-on-lines.asd") (:module :src - :components ((:file "packages") + :components ((:file "contextl-hacks") + (:file "packages") + (:file "utilities") (:file "display") (:file "attribute") - + (:file "description-class") + (:file "description") + + + + (:module :standard-descriptions + :components ((:file "t") + (:file "edit") + (:file "symbol") + (:file "list") + (:file "clos")) + ) + :serial t)) - (:file "description")) - :serial t)) + :serial t)) :serial t - :depends-on (:contextl :arnesi)) + :depends-on (:contextl :arnesi :alexandria)) + + + (defsystem :lisp-on-lines.test :components ((:module :src :components ((:file "packages-test") (:file "description-test") (:file "attribute-test") - (:file "display-test")) - :serial t)) + (:file "display-test") + (:module :ucw + :components ((:file "ucw-test")) + :serial t)) + :serial t) + (:module :tests + :components ((:module :bug + :components ((:file "0")))))) + :serial t + + + :depends-on (:lisp-on-lines :lisp-on-lines-ucw :stefil)) + - :depends-on (:lisp-on-lines :stefil)) +(if (asdf:find-system :asdf-system-connections nil) + (asdf:oos 'asdf:load-op :ucw-system-connections) + (#+sbcl sb-int:style-warn #-sbcl warn "UCW suggests asdf-system-connections in order to optionally integrate some other libraries. See http://www.cliki.net/asdf-system-connections for details and download instructions.")) diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp index 554b1a7..632cba7 100644 --- a/src/attribute-test.lisp +++ b/src/attribute-test.lisp @@ -5,18 +5,18 @@ (deftest test-attribute-value () (eval '(progn - (define-description attribute-test-2 () + (define-description attribute-test-description () ((attribute-1 :value "VALUE") (attribute-2 :function (constantly "VALUE")))) (deflayer attribute-test) - (define-description attribute-test-2 () + (define-description attribute-test-description () ((attribute-1 :value "VALUE2") (attribute-2 :function (constantly "VALUE2"))) (:in-layer . attribute-test)))) - (let ((d (find-description 'attribute-test-2))) + (let ((d (find-description 'attribute-test-description))) (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value))) @@ -30,13 +30,12 @@ (test-attribute-value) (eval '(progn (deflayer attribute-property-test) - (define-description attribute-test-2 () + (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-2))) + (let ((d (find-description 'attribute-test-description))) (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value))) @@ -48,6 +47,28 @@ (is (equalp (attribute-value nil (find-attribute d 'attribute-1)) (attribute-value nil (find-attribute d 'attribute-2)))) (is (equalp "VALUE2" (attribute-value nil (find-attribute d 'attribute-1)))))))) + +(deftest test-attribute-with-different-class () + (eval '(progn +;;;; We cannot ever redefine this class ic think... +;;; as attributes are also slot meta-objects. + (unless (find-class 'test-attribute-class nil) + (define-layered-class + test-attribute-class (lol::standard-attribute) + ((some-slot :initarg :some-slot :layered-accessor some-slot)))) + + (define-description test-attribute-with-different-class-description () + ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!"))))) + + (let* ((d (find-description 'test-attribute-with-different-class-description)) + + (a (find-attribute d 'attribute-with-different-class))) + (is (eq (class-of a) + (find-class 'test-attribute-class))) + (is (equalp "BRILLANT!" (some-slot a))))) + + + diff --git a/src/attribute.lisp b/src/attribute.lisp dissimilarity index 82% index 5c8b03a..10bcb70 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -1,88 +1,228 @@ -(in-package :lisp-on-lines) - - -(define-layered-class attribute () - ()) - -(defgeneric eval-attribute-initarg (attribute initarg) - (:method (a i) - nil)) - -(defmethod eval-attribute-initarg (attribute (initarg (eql :function))) - t) -(define-layered-function attribute-value (object attribute)) - - - -(deflayer LISP-ON-LINES) -(ensure-active-layer 'lisp-on-lines) - -(defvar *standard-direct-slot-initarg-symbols* - '(:layered :class :in-layer :name :readers :writers :initargs :allow-other-keys :special)) - -(define-layered-function special-slot-values (description slot-name) - (:method-combination append)) - -(define-layered-class attribute-special-layered-direct-slot-definition - (attribute contextl::special-layered-direct-slot-definition) - (initargs)) - -(defmethod shared-initialize :around ((instance attribute-special-layered-direct-slot-definition) slots &rest initargs ) - (setf (slot-value instance 'initargs) - (apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*)) - (call-next-method)) - -(define-layered-class standard-attribute - (attribute contextl::layered-effective-slot-definition-in-layers) - ((direct-slots) - (description - :layered-accessor description-of) - (label - :initarg :label - :layered-accessor attribute-label - :layered t - :initform nil) - (function - :initarg :function - :layered-accessor attribute-function - :layered t) - (value - :initarg :value - :layered t))) - -(define-layered-method attribute-value (object attribute) - (funcall (attribute-function attribute) object)) - -(defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs) - (declare (ignore initargs)) - (setf (attribute-function attribute) - (lambda (object) - (slot-value attribute 'value))) - (call-next-method)) - -(defun attribute-name (attribute) - (closer-mop:slot-definition-name attribute)) - -(define-layered-method slot-value-using-layer -; :in-layer lisp-on-lines - :around (class (attribute standard-attribute) slot reader) - (loop for (key var) on (special-slot-values (slot-value attribute 'description) - (attribute-name attribute)) - :if (eq (closer-mop:slot-definition-name slot) key) - :do (return-from slot-value-using-layer var)) - (call-next-method)) - -(define-layered-method display-using-description - ((attribute standard-attribute) display object &rest args) - (declare (ignore args)) - (format display "~@[~A ~]~A" (attribute-label attribute) - (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 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 ""))) + + +(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) + (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+")))) + +(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) + (new-value class (attribute standard-attribute) property writer) + + (when (or *bypass-property-layered-function* + (not (slot-definition-layeredp property))) + (return-from slot-value-using-layer (call-next-method))) + + + ;;FIXME: this is wrong for so many reasons. + (let ((layer + (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context)) + :key #'class-name))))) + + + (flet ((do-set-slot() + + (let ((fn + (let ((*bypass-property-layered-function* t)) + (if (slot-boundp-using-class class attribute property) + (slot-value-using-class class attribute property) + (setf (slot-value-using-class class attribute property) + (property-layered-function + (attribute-description attribute) + (attribute-name attribute) + (closer-mop:slot-definition-name property))))))) + ;(dprint "We are setting the fn ~A " fn) + (when (not (generic-function-methods fn)) + ; (dprint "... there are no methods on it ever") + ;; * 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)) + ,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))))) + + + ;; finally, specialize this property to this description. + (ensure-layered-method + fn + `(lambda (description) + ,new-value) + :in-layer layer + :specializers (list (class-of (attribute-description attribute) + )))))) + + (if (slot-boundp attribute 'description-class) + (do-set-slot) + (push (lambda () (do-set-slot)) + (slot-value attribute 'initfunctions)))))) + + +(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) + + (when (not (slot-boundp-using-class class attribute property)) + ;; If the slot is unbound, we search for its layered-function + + (let ((fn (property-layered-function + (attribute-description attribute) + + (attribute-name attribute) + (closer-mop:slot-definition-name property)))) + (dprint ".. not bound yet, have function ~A" fn) + (if (generic-function-methods fn) + (let ((*bypass-property-layered-function* t)) + ; (dprint " This shit has been bound!. We gona set the _real_ slot to the generic function like.") + (setf (slot-value-using-class class attribute property) fn)) + (progn + ;(dprint "This shit aint never been bound nowhere! checking for initfunction...") + (when (slot-definition-initfunction property) + ;(dprint "At least we have an initfunction. sweeet") + (let ((*bypass-property-layered-function* nil)) + (setf (slot-value attribute (slot-definition-name property)) + (funcall (slot-definition-initfunction property))))))))) + + ;(dprint "If we're here, the slot should be bound") + + + (if (and + (contextl::slot-definition-layeredp property) + (not *bypass-property-layered-function*)) + (let ((fn (call-next-method))) + ;(dprint "... using fn ~A to get value" fn) + (funcall fn layer (attribute-description attribute))) + (call-next-method))) + + + + +(defun slot-boundp-using-property-layered-function (class attribute property) + (when (not + (let ((*bypass-property-layered-function* t)) + (slot-boundp-using-class class attribute property))) + ;; If the slot is unbound, we search for its layered-function + + (let ((fn (property-layered-function + (attribute-description attribute) + + (attribute-name attribute) + (closer-mop:slot-definition-name property)))) + (if (generic-function-methods fn) + (let ((*bypass-property-layered-function* t)) + (setf (slot-value-using-class class attribute property) fn)) + NIL)))) + +#+nil(define-layered-method slot-boundp-using-layer + :in-layer (layer t) + :around (class (attribute standard-attribute) property reader) + (if *bypass-property-layered-function* + (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))) + + + + + + + + + + + diff --git a/src/contextl-hacks.lisp b/src/contextl-hacks.lisp new file mode 100644 index 0000000..ec78c35 --- /dev/null +++ b/src/contextl-hacks.lisp @@ -0,0 +1,43 @@ +(in-package :contextl) + +;;; HACK: We are ending up with classes named NIL in the superclass list. +;;; These cannot be given the special object superclass when re-initializing +;;; is it will be in the subclasses superclasses AFTER this class, causing +;;; a confict. +;;; Since we don't care about these classes (?) this might work (?) + +(defmethod initialize-instance :around + ((class special-class) &rest initargs + &key direct-superclasses) + (declare (dynamic-extent initargs)) + (if (or + ;; HACK begins + (not (ignore-errors (class-name class))) + ;; ENDHACK + (loop for superclass in direct-superclasses + thereis (ignore-errors (subtypep superclass 'special-object)))) + (call-next-method) + (progn (apply #'call-next-method class + :direct-superclasses + (append direct-superclasses + (list (find-class 'special-object))) + initargs)))) + +(defmethod reinitialize-instance :around + ((class special-class) &rest initargs + &key (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + (if direct-superclasses-p + (if (or ; Here comes the hack + (not (class-name class)) + ;endhack + (loop for superclass in direct-superclasses + thereis (ignore-errors (subtypep superclass 'special-object)))) + (call-next-method) + (apply #'call-next-method class + :direct-superclasses + (append direct-superclasses + (list + (find-class 'special-object))) + initargs))) + (call-next-method)) \ No newline at end of file diff --git a/src/description-class.lisp b/src/description-class.lisp dissimilarity index 96% index 9bf31e0..f43beca 100644 --- a/src/description-class.lisp +++ b/src/description-class.lisp @@ -1,122 +1,164 @@ -(in-package :lisp-on-lines) - -;;; * The Description Meta-Meta-Super class. - -(defclass description-special-layered-access-class - (contextl::special-layered-access-class) - ((original-name :initarg original-name) - (description-layer :initarg description-layer) - (instance))) - -(defmethod closer-mop:direct-slot-definition-class - ((class description-special-layered-access-class) - &key &allow-other-keys) - (find-class 'attribute-special-layered-direct-slot-definition)) - -(defmethod closer-mop:effective-slot-definition-class - ((class description-special-layered-access-class) - &key name &allow-other-keys) - (declare (ignore name)) - (find-class 'standard-attribute)) - -(defmethod closer-mop:compute-effective-slot-definition :around - ((class description-special-layered-access-class) name direct-slot-definitions) - (declare (ignore name)) - (let ((slotd (call-next-method))) - (setf (slot-value slotd 'direct-slots) direct-slot-definitions) - - (apply #'shared-initialize slotd nil (slot-value - (find t direct-slot-definitions - :test #'eq - :key #'slot-definition-layer ) - 'initargs)) - - slotd)) - -;;; * The Description Meta-Meta class. -(defclass description-class (description-special-layered-access-class layered-class) - () - (:default-initargs :defining-metaclass 'description-special-layered-access-class)) - -(defun initialize-description-class (class) - (let ((description (make-instance class))) - (setf (slot-value class 'instance) description) - (dolist (slotd (closer-mop:class-slots class)) - (setf (slot-value slotd 'description) description) - (dolist (slot (slot-value slotd 'direct-slots)) - (setf (slot-value slot 'initargs) - (loop - :for (initarg value) - :on (slot-value slot 'initargs) - :by #'cddr - :nconc (list initarg - (if (eval-attribute-initarg slotd initarg) - (eval value) - value)))) - (ensure-layered-method - 'special-slot-values - `(lambda (description attribute) - (list ,@(loop - :for (initarg value) - :on (slot-value slot 'initargs) - :by #'cddr - :nconc (list (list 'quote (or (find-slot-name-from-initarg - (class-of slotd) initarg) initarg)) - - value)))) - :in-layer (slot-definition-layer slot) - :qualifiers '(append) - :specializers (list class (closer-mop:intern-eql-specializer (closer-mop:slot-definition-name slotd)))))))) - -(defmethod closer-mop:finalize-inheritance :after ((class description-class)) - (initialize-description-class class)) - -(define-layered-class description () - ((identity :function #'identity)) - (:metaclass description-class) - (description-layer t)) - -(eval-when (:load-toplevel :execute) - (closer-mop:finalize-inheritance (find-class 'description))) - -;;; The layer itself. -#+nil(deflayer description () - () - (:metaclass description)) - -#+nil (defmethod print-object ((object description) stream) - (call-next-method)) - -(defgeneric find-description-class (name &optional errorp) - ;; !-- Sometimes it gets inited, sometimes it don't. - (:method :around (name &optional errorp) - (let ((class (call-next-method))) - (unless (slot-boundp class 'instance) - (initialize-description-class class)) - class)) - (:method ((name (eql t)) &optional errorp) - (declare (ignore errorp)) - (find-class 'description t)) - (:method ((name symbol) &optional errorp) - (or (find-class (defining-description name) errorp) - (find-description-class t))) - (:method ((description description) &optional errorp) - (declare (ignore errorp)) - (class-of description))) - -;;; A handy macro. -(defmacro define-description (name &optional superdescriptions &body options) - (let ((description-name (defining-description name))) - - (destructuring-bind (&optional slots &rest options) options - `(prog1 - (defclass ,description-name ,(append (mapcar #'defining-description superdescriptions) '(description)) - ,(if slots slots '()) - ,@options - ,@(unless (assoc :metaclass options) - '((:metaclass description-class))) - (original-name . ,name)) - (initialize-description-class (find-description-class ',description-name)))))) - - - +(in-package :lisp-on-lines) + +;;;; * DESCRIPTIONS +;;;; A description is an object which is used +;;;; to describe another object. + +;;; HACK: +;;; Since i'm not using deflayer, ensure-layer etc, +;;; There are a few places where contextl gets confused +;;; trying to locate my description layers. + +;;; TODO: investigate switching to deflayer! + +(defun contextl::prepare-layer (layer) + (if (symbolp layer) + (if (eq (symbol-package layer) + (find-package :description-definers)) + layer + (contextl::defining-layer layer)) + + layer)) + +(defmethod find-layer-class :around ((layer symbol) &optional errorp environment) + (if (eq (symbol-package layer) + (find-package :description-definers)) + (find-class layer) + (call-next-method))) + +;;; #+HACK +;;; I'm having some 'issues' with +;;; compiled code and my initialization. +;;; So this hack initializes the world. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *defined-descriptions* nil)) + +(defclass description-access-class (standard-layer-class contextl::special-layered-access-class ) + ((defined-in-descriptions :initarg :in-description) + (mixin-class-p :initarg :mixinp))) + +(defmethod direct-slot-definition-class + ((class description-access-class) &key &allow-other-keys) + (find-class 'direct-attribute-definition-class)) + +(defmethod effective-slot-definition-class + ((class description-access-class) &key &allow-other-keys) + (find-class 'effective-attribute-definition-class)) + +(defmethod compute-effective-slot-definition + ((class description-access-class) name direct-slot-definitions) + (declare (ignore name)) + (let ((attribute (call-next-method))) + (setf (attribute-direct-attributes attribute) direct-slot-definitions) + (setf (attribute-object attribute) + (make-instance 'standard-attribute + :name name + 'effective-attribute attribute + 'description-class class)) + attribute)) + + +(defclass standard-description-class (description-access-class layered-class) + () + (:default-initargs :defining-metaclass 'description-access-class)) + +(defmethod validate-superclass + ((class standard-description-class) + (superclass standard-class)) + t) + +(defclass standard-description-object (standard-layer-object) ()) + +(defun description-class-name (description-class) + (read-from-string (symbol-name (class-name description-class)))) + +(defun initialize-description-class (class) + + ;;; HACK: initialization does not happen properly + ;;; when compiling and loading or something like that. + ;;; Obviously i'm not sure why. + ;;; So we're going to explicitly initialize things. + ;;; For now. --drewc + + (pushnew class *defined-descriptions*) + + ;;; ENDHACK. + + (let* ((description (find-layer class)) + (attribute-objects (mapcar #'attribute-object (class-slots (class-of description)))) + (defining-classes (partial-class-defining-classes (class-of description)))) + + + + (loop + :for (layer class) + :on defining-classes :by #'cddr + :do (funcall-with-layer-context + (adjoin-layer (find-layer layer) (current-layer-context)) + (lambda () + (loop :for direct-slot :in (class-direct-slots class) + :do (let ((attribute + (find (slot-definition-name direct-slot) + attribute-objects + :key #'attribute-name))) + (apply #'reinitialize-instance attribute + (direct-attribute-properties direct-slot)) + (apply #'change-class attribute (attribute-class attribute) (direct-attribute-properties direct-slot)) + + (setf (slot-value description (attribute-name attribute)) + attribute)))))))) + +;;;; HACK: run this at startup till we figure things out. +(defun initialize-descriptions () + (map nil #'initialize-description-class + (setf *defined-descriptions* + (remove-duplicates *defined-descriptions*)))) + +(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '())) + (declare (dynamic-extent initargs)) + (prog1 + (if (loop for direct-superclass in direct-superclasses + thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses + (append direct-superclasses + (list (find-class 'standard-description-object))) + initargs)) + (initialize-description-class class))) + + +(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) + (declare (dynamic-extent initargs)) +; (warn "CLASS ~A ARGS ~A:" class initargs) + (prog1 + (if (or (not direct-superclasses-p) + (loop for direct-superclass in direct-superclasses + thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses + (append direct-superclasses + (list (find-class 'standard-description-object))) + initargs)) + (initialize-description-class class))) + + +(defmethod print-object ((object standard-description-object) stream) + (print-unreadable-object (object stream :type nil :identity t) + (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object))))) + +(defmethod print-object ((object standard-description-class) stream) + (print-unreadable-object (object stream :type t :identity t) + (princ (ignore-errors (description-print-name (find-layer object))) stream))) + +(defun find-description (name) + (find-layer (find-class (defining-description name)))) + + + + + + diff --git a/src/description-test.lisp b/src/description-test.lisp index c42d672..1910dae 100644 --- a/src/description-test.lisp +++ b/src/description-test.lisp @@ -40,12 +40,6 @@ (with-active-layers (test-description-layer) (is (equal "BRILLANT-IN-LAYER" (slot-value att 'lol::label)))))) -(deftest test-special-slot-values () - (test-simple-attributes) - (is (equalp '(lol::label "BRILLANT!") - (lol::special-slot-values - (find-description 'test-description) 'test-attribute)))) - (defparameter *atomic-type-specifiers* '(arithmetic-error function simple-condition array generic-function simple-error diff --git a/src/description.lisp b/src/description.lisp dissimilarity index 89% index 4195bb2..49dd5ed 100644 --- a/src/description.lisp +++ b/src/description.lisp @@ -1,65 +1,80 @@ -(in-package :lisp-on-lines) - -(define-description description ()) - -(defun find-description (name) - (slot-value (find-description-class name) 'instance)) - -(defun description-attributes (description) - (closer-mop:class-slots (find-description-class description))) - -(define-layered-function attributes (description)) - -(define-layered-method attributes (description) - (description-attributes description)) - -;;;!-- TODO: This is a prime candidate for optimization -(defun find-attribute (description attribute-name) - (find attribute-name (description-attributes description) :key #'attribute-name)) - -(define-display ((description description)) - (format *display* "~{~A~%~}" - (mapcar - (lambda (attribute) - (with-output-to-string (*display*) - (display-attribute attribute))) - (attributes description)))) - - -(define-layered-method description-of (object) - (find-description 't)) - -(define-layered-method description-of ((symbol symbol)) - (find-description 'symbol)) - -(define-description symbol () - ((identity :label "Symbol:") - (name - :function #'symbol-name - :label "Name:") - (value - :label "Value:" - :function - (lambda (symbol) - (if (boundp symbol) - (symbol-value symbol) - ""))) - (package :function #'symbol-package - :label "Package:") - (function :label "Function:" - :function - (lambda (symbol) - (if (fboundp symbol) - (symbol-function symbol) - ""))))) - - - - - - - - - - - +(in-package :lisp-on-lines) + +(define-layered-function description-of (thing) + (:method (thing) + (find-description 't))) + +(defun description-print-name (description) + (description-class-name (class-of description))) + +(defun find-attribute (description attribute-name) + (slot-value description attribute-name)) + +#+nil(mapcar (lambda (slotd) + (slot-value-using-class (class-of description) description slotd)) + (class-slots (class-of description))) +(defun description-attributes (description) + (mapcar #'attribute-object (class-slots (class-of description)))) + +(define-layered-function attributes (description) + (:method (description) + (remove-if-not + (lambda (attribute) + (and (eq (class-of description) + (print (slot-value attribute 'description-class))) + (some #'layer-active-p + (mapcar #'find-layer + (slot-definition-layers + (attribute-effective-attribute-definition attribute)))))) + (description-attributes description)))) + + +;;; A handy macro. +(defmacro define-description (name &optional superdescriptions &body options) + (let ((description-name (defining-description name))) + (destructuring-bind (&optional slots &rest options) options + (let ((description-layers (cdr (assoc :in-description options)))) + (if description-layers + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(loop + :for layer + :in description-layers + :collect `(define-description + ,name ,superdescriptions ,slots + ,@(acons + :in-layer (defining-description layer) + (remove :in-description options :key #'car))))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ; `(progn + (defclass ,description-name + ,(append (mapcar #'defining-description + superdescriptions) + (unless (or (eq t name) + (assoc :mixinp options)) + (list (defining-description t)))) + ,(if slots slots '()) + ,@options + ,@(unless (assoc :metaclass options) + '((:metaclass standard-description-class)))) +; (initialize-description) + (find-description ',name))))))) + + + + + + + + + + + + + + + + + + + + diff --git a/src/display-test.lisp b/src/display-test.lisp dissimilarity index 90% index 91068bd..6b3f9c8 100644 --- a/src/display-test.lisp +++ b/src/display-test.lisp @@ -1,21 +1,20 @@ -(in-package :lol-test) - -(in-suite lisp-on-lines) - -(deftest test-define-display () - (test-attribute-property-inheriting) - - (deflayer test-display) - - (define-display - :in-layer test-display ((description attribute-test-2)) - (format *display* "BRILLANT!")) - - (let ((before (display-using-description - (find-description 'attribute-test-2) - nil :foo))) - (with-active-layers (test-display) - (is (equalp "BRILLANT!" (display-using-description - (find-description 'attribute-test-2) - nil :foo)))))) - \ No newline at end of file +(in-package :lol-test) + +(in-suite lisp-on-lines) + +(deftest (test-define-display :compile-before-run t) () + + (define-description test-display ()) + + (define-display ((description test-display)) + t "BRILLANT!") + + (is (equalp "BRILLANT!" (display-using-description + (find-description 'test-display) + nil :foo)))) + +(deftest test-symbol-display () + (is (stringp (display nil nil)))) + + + \ No newline at end of file diff --git a/src/display.lisp b/src/display.lisp index 91cbd06..862cf98 100644 --- a/src/display.lisp +++ b/src/display.lisp @@ -1,7 +1,10 @@ (in-package :lisp-on-lines) -(defvar *object*) +(defvar *description*) (defvar *display*) +(defvar *object*) + +(deflayer display-layer) (define-layered-function display-using-description (description display object &rest args) (:documentation @@ -12,33 +15,39 @@ (define-layered-method display-using-description :around (description display object &rest args) - (let ((*display* display) + (declare (ignorable args)) + (let ((*description* description) + (*display* display) (*object* object)) + (call-next-method))) + + (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)) -(defun display-attribute (attribute) - (display-using-description attribute *display* *object*)) + (defmacro define-display (&body body) - (loop with in-layerp = (eq (car body) :in-layer) - with layer = (if in-layerp (cadr body) 't) - for tail on (if in-layerp (cddr body) body) + (loop with in-descriptionp = (eq (car body) :in-description) + with description = (if in-descriptionp (cadr body) 't) + for tail on (if in-descriptionp (cddr body) body) until (listp (car tail)) collect (car tail) into qualifiers finally - (when (member :in-layer qualifiers) - (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers.")) + (when (member :in-description qualifiers) + (error "Incorrect occurrence of :in-description in defdisplay. Must occur before qualifiers.")) (return (destructuring-bind (description-spec &optional (display-spec (gensym)) (object-spec (gensym))) (car tail) `(define-layered-method display-using-description - :in-layer ,layer + :in-layer ,(if (eq t description) + t + (defining-description description)) ,@qualifiers (,(if (listp description-spec) (list (first description-spec) diff --git a/src/packages-test.lisp b/src/packages-test.lisp index 7b807af..f10bf0f 100644 --- a/src/packages-test.lisp +++ b/src/packages-test.lisp @@ -1,3 +1,3 @@ (cl:defpackage #:lol-test - (:use #:cl #:lisp-on-lines #:stefil #:contextl)) \ No newline at end of file + (:use #:cl #:lisp-on-lines #:lisp-on-lines-ucw #:stefil #:contextl)) \ No newline at end of file diff --git a/src/packages.lisp b/src/packages.lisp index b1f48db..e65ff7c 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -1,14 +1,17 @@ (defpackage #:lisp-on-lines (:use :common-lisp - #:contextl) + #:contextl + #:closer-mop + #:alexandria) (:nicknames #:lol) (:export ;; Descriptions #:find-description #:define-description - + #:with-active-descriptions + ;; Displays #:define-display #:display @@ -18,6 +21,8 @@ ;; Attributes #:find-attribute + #:attribute + #:attributes #:attribute-label #:attribute-function #:attribute-value)) diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp new file mode 100644 index 0000000..33a4cce --- /dev/null +++ b/src/standard-descriptions/clos.lisp @@ -0,0 +1,13 @@ +(in-package :lisp-on-lines) + +(define-description standard-object () + ((class-slots :label "Slots" + :function (compose 'class-slots 'class-of)))) + +(define-layered-method description-of ((object standard-object)) + (find-description 'standard-object)) + + + + + diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp new file mode 100644 index 0000000..d4a913e --- /dev/null +++ b/src/standard-descriptions/edit.lisp @@ -0,0 +1,60 @@ +(in-package :lisp-on-lines) + + +(define-description editable () + () + (:mixinp t)) + +(define-description T () + ((editp :label "Edit by Default?" + :value nil + :editp nil) + (identity :editp nil) + (type :editp nil) + (class :editp nil)) + (:in-description editable)) + +(define-layered-function (setf attribute-value) (v o a) + (:method (value object attribute) + (let ((setter (attribute-setter attribute))) + (if setter + (funcall setter value object) + (error "No setter in ~A for ~A" attribute object))))) + +(define-layered-class standard-attribute + :in-layer #.(defining-description 'editable) + () + ((edit-attribute-p + :initform :inherit + :accessor %attribute-editp + :initarg :editp + :layered t) + (setter + :initarg :setter + :layered t + :accessor attribute-setter + :initform nil))) + +(define-layered-function attribute-editp (object attribute) + (:method (object attribute) nil)) + +(define-layered-method attribute-editp + :in-layer #.(defining-description 'editable) + (object (attribute standard-attribute)) + + (if (eq :inherit (%attribute-editp attribute)) + (attribute-value object (find-attribute + (attribute-description attribute) + 'editp)) + (%attribute-editp attribute))) + + +(define-layered-method display-using-description + :in-layer #.(defining-description 'editable) + ((attribute standard-attribute) display object &rest args) + + (declare (ignore args)) + (format t "Editabpe? ~A ~A" (attribute-label attribute) attribute)) + + + \ No newline at end of file diff --git a/src/standard-descriptions/list.lisp b/src/standard-descriptions/list.lisp new file mode 100644 index 0000000..71c65f2 --- /dev/null +++ b/src/standard-descriptions/list.lisp @@ -0,0 +1,20 @@ +(in-package :lisp-on-lines) + +(define-description cons () + ((car :label "First" :function #'car) + (cdr :label "Rest" :function #'cdr))) + +(define-description cons () + ((editp :value t :editp nil) + (car :setter #'rplaca) + (cdr :setter #'rplacd)) + (:in-description editable)) + +(define-layered-method description-of ((c cons)) + (find-description 'cons)) + + + + + + diff --git a/src/standard-descriptions/symbol.lisp b/src/standard-descriptions/symbol.lisp new file mode 100644 index 0000000..300b481 --- /dev/null +++ b/src/standard-descriptions/symbol.lisp @@ -0,0 +1,25 @@ +(in-package :lisp-on-lines) + +(define-layered-method description-of ((symbol symbol)) + (find-description 'symbol)) + +(define-description symbol () + ((identity :label "Symbol:") + (name + :function #'symbol-name + :label "Name:") + (value + :label "Value:" + :function + (lambda (symbol) + (if (boundp symbol) + (symbol-value symbol) + ""))) + (package :function #'symbol-package + :label "Package:") + (function :label "Function:" + :function + (lambda (symbol) + (if (fboundp symbol) + (symbol-function symbol) + ""))))) \ No newline at end of file diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp new file mode 100644 index 0000000..fe4864f --- /dev/null +++ b/src/standard-descriptions/t.lisp @@ -0,0 +1,18 @@ +(in-package :lisp-on-lines) + +(define-description T () + ((identity :label nil :function #'identity) + (type :label "Type" :function #'type-of) + (class :label "Class" :function #'class-of))) + +(define-layered-method description-of (any-lisp-object) + (find-description 't)) + +(define-display ((description t)) + (format *display* "~{~A~%~}" + (mapcar + (lambda (attribute) + (with-output-to-string (*display*) + (display-attribute attribute))) + (attributes description)))) + diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp new file mode 100644 index 0000000..8dae20a --- /dev/null +++ b/src/ucw/html-description.lisp @@ -0,0 +1,50 @@ +(in-package :lisp-on-lines) + +(export '(html-description)) + +(define-description html-description () + ((css-class :value "lol-description") + (dom-id :function (lambda (x) + (declare (ignore x)) + (symbol-name + (gensym "DOM-ID-"))))) + (:mixinp t)) + + +(define-description t (html-description) + () + (:in-description html-description)) + +(define-layered-class html-attribute () + ((css-class :accessor attribute-css-class + :initform "lol-attribute") + (dom-id :accessor attribute-dom-id :initform nil))) + +(define-layered-class standard-attribute + :in-layer #.(defining-description 'html-description) + (html-attribute) + ()) + +(define-display + :in-description html-description ((description t)) + (with-attributes (css-class dom-id) description + + (<:div + :class (attribute-value* css-class) + :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)) + (<:span + :class "lol-attribute-label" + (<:as-html (attribute-label attribute))) + (<:span + :class "lol-attribute-value" + (<:as-html (attribute-value* attribute)))))))) + + + + + diff --git a/src/ucw/lol-tags-test.lisp b/src/ucw/lol-tags-test.lisp new file mode 100644 index 0000000..dcbc51e --- /dev/null +++ b/src/ucw/lol-tags-test.lisp @@ -0,0 +1,3 @@ +(in-package :lol-test) + + diff --git a/src/ucw/lol-tags.lisp b/src/ucw/lol-tags.lisp new file mode 100644 index 0000000..abf7982 --- /dev/null +++ b/src/ucw/lol-tags.lisp @@ -0,0 +1,99 @@ +(in-package :lisp-on-lines-ucw) + +;;; * Lisp on Lines YACLML tags. + +;;; * Utilities + +(defun gen-id (string) + `(js:gen-js-name-string :prefix ,string)) + +;;; ** ACTION tags + +;;; These tags take UCW "actions" and create the appropriate HTML +;;; tag to signal their execution. + +(defmacro %with-action-unique-names (&body body) + "These magic macros." + `(with-unique-names (url action-object action-id current-frame) + (assert (xor action action* function) nil + "Must supply only one of ACTION, ACTION* or FUNCTION") + (rebinding (id) + `(let* ((,current-frame (context.current-frame *context*)) + (,action-object ,(or action* + `(lol-ucw:make-action + ,(or function + `(lambda () + (with-call/cc ,action)))))) + (,action-id (register-action-in-frame + ,current-frame + ,action-object)) + + + (,url (compute-url ,action-object *current-component*))) + (declare (ignorable ,action-id ,url)) + ,,@body)))) + + +(deftag-macro special-slot-bindings (class initargs-plist) "returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS." (let ((initargs.slot-names-alist (initargs.slot-names class))) @@ -52,5 +57,9 @@ Descriptoons are represented as ContextL classes and layers. To avoid nameclashe (when slot-name ;ignore invalid initargs. (good idea/bad idea?) (list slot-name value)))))) +(defun dprint (format-string &rest args) + (apply #'format t (concatenate 'string format-string "~%") args)) + + -- 2.20.1