--- /dev/null
+(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
(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
: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."))
(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)))
(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)))
(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)))))
+
+
+
-(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)))
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+(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
-(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))))
+
+
+
+
+
+
(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
-(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)
- "<UNBOUND>")))
- (package :function #'symbol-package
- :label "Package:")
- (function :label "Function:"
- :function
- (lambda (symbol)
- (if (fboundp symbol)
- (symbol-function symbol)
- "<UNBOUND>")))))
-
-
-
-
-
-
-
-
-
-
-
+(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)))))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-(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
(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
(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)
(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
(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
;; Attributes
#:find-attribute
+ #:attribute
+ #:attributes
#:attribute-label
#:attribute-function
#:attribute-value))
--- /dev/null
+(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))
+
+
+
+
+
--- /dev/null
+(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
--- /dev/null
+(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))
+
+
+
+
+
+
--- /dev/null
+(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)
+ "<UNBOUND>")))
+ (package :function #'symbol-package
+ :label "Package:")
+ (function :label "Function:"
+ :function
+ (lambda (symbol)
+ (if (fboundp symbol)
+ (symbol-function symbol)
+ "<UNBOUND>")))))
\ No newline at end of file
--- /dev/null
+(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))))
+
--- /dev/null
+(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))))))))
+
+
+
+
+
--- /dev/null
+(in-package :lol-test)
+
+
--- /dev/null
+(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 <lol:a (&attribute (id (gen-id "lol-action"))
+ action action* function
+ &allow-other-attributes others
+ &body body)
+ "A Simple <:A which does not require javascript."
+ (%with-action-unique-names
+ `(<:a :href (print-uri-to-string ,url)
+ :id ,id
+ ,@others
+ ,@body)))
+
+(deftag-macro <lol:form (&attribute (id (gen-id "lol-form"))
+ action action* function
+ &allow-other-attributes others
+ &body body)
+ "A Simple form which does not require javascript. "
+ (%with-action-unique-names
+ `(<:form :action (print-uri-to-string-sans-query ,url)
+ :id ,id
+ ,@others
+ (dolist (query (uri.query ,url))
+ (if (string= ,+action-parameter-name+ (car query))
+ (<:input :type "hidden" :name ,+action-parameter-name+
+ :value (cdr query)
+ :id ,action-id)
+ (<:input :type "hidden" :name (car query) :value (cdr query))))
+ ,@body)))
+
+(deftag-macro <lol:submit (&attribute (id (gen-id "lol-submit"))
+ action action* function value
+ &allow-other-attributes others
+ &body body)
+ (%with-action-unique-names
+ `(<:input :type "submit"
+ :value (or ,value ,@body)
+ :name (format nil "~A~A~A"
+ ,+action-parameter-name+
+ ,+action-compound-name-delimiter+
+ ,action-id))))
+
+;;; * CALLBACK tags
+
+;;; All these tags take some kind of input, and execute a UCW callback.
+
+(deftag-macro <lol:input (&attribute accessor reader writer
+ (id (gen-id "lol-input"))
+ &allow-other-attributes others)
+ (let ((reader (or reader accessor))
+ (writer (or writer `(lambda (v)
+ (setf ,accessor v)))))
+
+ `(<:input :value ,reader
+ :name (register-callback ,writer)
+ ,@others)))
+
+
+
+
+
+
+
+
+
--- /dev/null
+
+(defpackage lisp-on-lines-ucw
+ (:documentation "An LoL Layer over ucw.basic")
+ (:nicknames #:lol-ucw)
+ (:use #:lisp-on-lines #:ucw :common-lisp :arnesi :yaclml :puri)
+ (:shadow
+ #:standard-window-component
+ #:make-action
+ #:standard-action
+ #:uri-parse-error
+ #:standard-application)
+
+ (:shadowing-import-from :ucw
+ #:parent)
+
+ (:import-from :ucw
+ #:register-action-in-frame
+ #:+action-parameter-name+
+ #:context.current-frame
+ #:uri.query
+ #:*current-component*
+ #:find-action
+ #:service)
+
+ (:export
+ ;;; Symbols marked ";*" are not from UCW
+ ;;; but either shadowed or created for lol.
+
+ #:defcomponent
+
+ #:uri.query
+
+ ;; Standard Server
+ #:standard-server
+ #:startup-server
+ #:shutdown-server
+
+
+ ;; Standard Application
+ #:standard-application
+ #:register-application
+ #:service
+
+ ;; Standard Request Context
+ #:*context*
+ #:context.current-frame
+ #:context.window-component
+
+
+ ;; Actions
+ #:call
+ #:make-action
+ #:find-action
+ #:defaction
+ #:defmethod/cc
+
+ #:call-component
+ #:answer-component
+
+ ;; Entry Points
+ #:defentry-point
+
+ ;; Standard Components
+ #:render
+ #:component
+ #:standard-component-class
+
+ #:standard-window-component ;*
+ #:window-body
+
+ ))
+
+(defpackage :lisp-on-lines-tags
+ (:documentation "LoL convience yaclml tags.")
+ (:use)
+ (:nicknames #:<lol)
+ (:export
+ #:component-body
+ #:render-component
+ #:a
+ #:area
+ #:form
+ #:input
+ #:button
+ #:simple-select
+ #:select
+ #:option
+ #:textarea
+
+ #:integer-range-select
+ #:month-day-select
+ #:month-select
+
+ #:text
+ #:password
+ #:submit
+ #:simple-form
+ #:simple-submit
+
+ #:localized
+ #:script))
\ No newline at end of file
--- /dev/null
+(in-package :lisp-on-lines-ucw)
+
+(defmacro defaction (&rest args-and-body)
+ `(arnesi:defmethod/cc ,@args-and-body))
+
+(defun make-action (lambda &rest args)
+ (let ((ucw::*default-action-class* 'basic-action))
+ (apply #'ucw::make-action lambda args)))
+
+(defclass standard-application (ucw:basic-application)
+ ())
+
+(defclass standard-request-context (ucw::standard-request-context)
+ ())
+
+(defmethod ucw:request-context-class list ((application standard-application))
+ 'standard-request-context)
+
+(defvar +action-compound-name-delimiter+ #\|)
+
+(defmethod ucw::find-action-id :around ((context standard-request-context))
+ (or
+ (let (id)
+ (ucw::find-parameter
+ (context.request context) ucw::+action-parameter-name+
+ :test (lambda (name parameter)
+ (declare (ignore name))
+ (destructuring-bind (param-name &optional action-id)
+ (split-sequence:split-sequence
+ +action-compound-name-delimiter+ parameter)
+ (when (and action-id
+ (string= ucw::+action-parameter-name+ param-name))
+ (setf id action-id)))))
+ id)
+ (call-next-method)))
+
+(defcomponent standard-window-component
+ (ucw:basic-window-component)
+ ((body
+ :initform nil
+ :accessor window-body
+ :component t
+ :initarg :body)))
+
+(defmethod ucw:render-html-body ((window standard-window-component))
+ (ucw:render (window-body window)))
--- /dev/null
+(in-package :lol-test)
+
+(defclass lol-test-server (standard-server)
+ ())
+
+(defclass lol-test-application (standard-application)
+ ()
+ (:default-initargs
+ :url-prefix "/lisp-on-lines.test/"
+; :www-roots (list (cons "static/" (project-relative-pathname #P"wwwroot/")))
+))
+
+(defparameter *lol-test-ucw-application* (make-instance 'lol-test-application))
+
+(defun make-backend ()
+ (ucw::make-backend
+ :httpd
+ :host "localhost"
+ :port 9090))
+
+(defun make-server ()
+ (make-instance
+ 'lol-test-server
+ :backend (make-backend)))
+
+(defparameter *lol-test-ucw-server* (make-server))
+
+(register-application *lol-test-ucw-server* *lol-test-ucw-application*)
+
+(defentry-point "index.ucw" (:application *lol-test-ucw-application*) ()
+ (call 'lol-test-window))
+
+(defun startup-lol-ucw-test ()
+ (startup-server *lol-test-ucw-server*))
+
+(defun shutdown-lol-ucw-test ()
+ (shutdown-server *lol-test-ucw-server*))
+
+(defcomponent lol-test-window (standard-window-component)
+ ()
+ (:default-initargs
+ :body (make-instance 'lol-test-suite-component)))
+
+(define-symbol-macro $window (lol-ucw:context.window-component *context*))
+
+(define-symbol-macro $body (window-body $window))
+
+(defcomponent lol-test-suite-component ()
+ ((test :component lol-test-simple-action :accessor test)
+ (component :component lol-test-render :accessor component)))
+
+(define-symbol-macro $test (test $body))
+
+(define-symbol-macro $component (component $body))
+
+(defmethod render ((self lol-test-suite-component))
+ (<:H1 "Lisp On Lines Web test suite")
+ (render (slot-value self 'test))
+ (<:div
+ :style "border:1px solid black;"
+ (render (slot-value self 'component))))
+
+(defcomponent lol-test-render ()
+ ((message :initform "test" :accessor message :initarg :message)))
+
+(defmethod render ((self lol-test-render))
+ (<:h3 :id "test-render"
+ (<:as-html (format nil "Hello ~A." (message self)))))
+
+(defcomponent lol-test-simple-action ()
+ ())
+
+(defmethod render ((self lol-test-simple-action))
+ (<:ul
+ (<:li (<lol:a
+ :function
+ (lambda ()
+ (setf (message $component)
+ (format nil "~A : ~A" (message $component) "FUNCTION")))
+ "Test <:A :FUNCTION type actions"))
+ (<:li
+ (<lol:a
+ :action (setf (message $component)
+ (format nil "~A : ~A" (message $component) "ACTION"))
+ "Test <:A :ACTION type actions"))
+ (<:li
+ (<lol:a
+ :action* (make-action
+ (lambda ()
+ (setf (message $component)
+ (format nil "~A : ~A" (message $component) "ACTION*"))))
+ "Test <:A :ACTION* type actions"))
+ (<:li
+ (<lol:a
+ :action (call-component $component (make-instance 'lol-test-answer))
+ "Test CALL/ANSWER"))
+ (<:li
+ (<lol:a
+ :action (call-component $component (make-instance 'lol-test-simple-form))
+ "Test Simple Form"))
+ (<:li
+ (<lol:a
+ :action (call-component $component (make-instance 'lol-test-multi-submit-form))
+ "Test Multi Form"))
+ (<:li
+ (<lol:a
+ :action (call-component $component (make-instance 'lol-test-input))
+ "Test Form input"))))
+
+(defcomponent lol-test-answer (lol-test-render) ()
+ (:default-initargs :message "CALL was ok. Go Back will answer"))
+
+(defmethod render :wrapping ((self lol-test-answer))
+ (call-next-method)
+ (<lol:a :action (answer-component self nil) "Go Back."))
+
+(defcomponent lol-test-simple-form (lol-test-render) ()
+ (:default-initargs :message "Testing Simple Form:"))
+
+(defmethod render :wrapping ((self lol-test-simple-form))
+ (call-next-method)
+ (<lol:form
+ :action (setf (message self) "Form Submitted")
+ (<:submit))
+ (<lol:a :action (answer-component self nil) "Go Back."))
+
+(defcomponent lol-test-multi-submit-form (lol-test-render) ()
+ (:default-initargs :message "Testing Simple Form:"))
+
+(defmethod render :wrapping ((self lol-test-multi-submit-form))
+ (call-next-method)
+ (<lol:form
+ :action (setf (message self) "Form Submitted")
+ (<:submit)
+ (<lol:submit :action (setf (message self) "Submit 2" )
+ :value "2")
+ (<lol:submit :action (setf (message self) "Submit 3")
+ 3))
+ (<lol:a :action (answer-component self nil) "Go Back."))
+
+(defcomponent lol-test-input (lol-test-render)
+ ()
+ (:default-initargs :message "Testing INPUTS"))
+
+(defmethod render :wrapping ((self lol-test-input))
+ (call-next-method)
+ (<lol:form
+ :function (constantly t)
+ (<lol:input :type "text" :accessor (message self))
+
+ (<:submit)
+ )
+ (<lol:a :action (answer-component self nil) "Go Back."))
+
+
+
+
+
+
+
+
(or (get symbol package)
(setf (get symbol package) (gensym))))))
+(defmacro with-active-descriptions (descriptions &body body)
+ `(with-active-layers ,(mapcar #'defining-description descriptions)
+
+ ,@body))
#|
Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name.
|#
(make-enclosing-package "DESCRIPTION-DEFINERS"))
(defun defining-description (name)
- "Takes the name of a layer and returns its internal name."
+ "Takes the name of a description and returns its internal name."
(case name
- ((t) 't)
((nil) (error "NIL is not a valid description name."))
(otherwise (enclose-symbol name *description-definers*))))
-
-(defmethod initargs.slot-names (class)
- "Returns ALIST of (initargs) . slot-name."
- (nreverse (mapcar #'(lambda (slot)
+(defmethod initargs.slots (class)
+ "Returns ALIST of (initargs) . slot."
+ (mapcar #'(lambda (slot)
(cons (closer-mop:slot-definition-initargs slot)
- (closer-mop:slot-definition-name slot)))
- (closer-mop:class-slots class))))
+ slot))
+ (closer-mop:class-slots class)))
-(defun find-slot-name-from-initarg (class initarg)
+(defun find-slot-using-initarg (class initarg)
(cdr (assoc-if #'(lambda (x) (member initarg x))
- (initargs.slot-names class))))
+ (initargs.slots class))))
+
;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
+;;;!-- do we still use this?
+
(defun initargs-plist->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)))
(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))
+
+
HCoop / clinton / lisp-on-lines.git / commitdiff