--- /dev/null
+(in-package :lol-test)
+
+(in-suite lisp-on-lines)
+
+(deftest test-attribute-value ()
+ (eval
+ '(progn
+ (define-description attribute-test-2 ()
+ ((attribute-1 :value "VALUE")
+ (attribute-2 :function (constantly "VALUE"))))
+
+ (deflayer attribute-test)
+
+ (define-description attribute-test-2 ()
+ ((attribute-1 :value "VALUE2")
+ (attribute-2 :function (constantly "VALUE2")))
+ (:in-layer . attribute-test))))
+
+ (let ((d (find-description 'attribute-test-2)))
+
+ (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
+
+
+ (with-active-layers (attribute-test)
+ (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-property-inheriting ()
+ (test-attribute-value)
+ (eval '(progn
+ (deflayer attribute-property-test)
+ (define-description attribute-test-2 ()
+ ((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)))
+
+ (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
+
+ (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
+ (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
+
+
+ (with-active-layers (attribute-test)
+ (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))))))))
+
+
+
+
\ No newline at end of file
--- /dev/null
+(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))
+
+(define-layered-method attribute-value (object attribute)
+ (funcall (attribute-function attribute) object))
+
+(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)))
+
+(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)
+ (display display (attribute-value object attribute))))
+
+
+
+
+
+
+
+
+
--- /dev/null
+(in-package :lol-test)
+
+(defsuite lisp-on-lines)
+
+(in-suite lisp-on-lines)
+
+(defclass lol-test-class ()
+ ((string-slot
+ :accessor string-slot
+ :initform "test"
+ :type string)
+ (number-slot
+ :accessor number-slot
+ :initform 12345
+ :type number)
+ (symbol-slot
+ :accessor symbol-slot
+ :initform 'symbol
+ :type symbol)))
+
+(deftest test-simple-define-description ()
+ (eval '(lol:define-description test-description ()
+ ((test-attribute :label "BRILLANT!"))))
+
+ (eval '(deflayer test-description-layer))
+
+ (eval '(lol:define-description test-description ()
+ ((test-attribute :label "BRILLANT-IN-LAYER"))
+ (:in-layer . test-description-layer))))
+
+(deftest test-T-description ()
+ (let ((d (find-description t)))
+ (is (find-attribute d 'identity))))
+
+(deftest test-simple-attributes ()
+ (test-simple-define-description)
+ (let* ((desc (find-description 'test-description))
+ (att (find-attribute desc 'test-attribute)))
+ (is (equal "BRILLANT!" (slot-value att 'lol::label)))
+ (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
+ atom hash-table simple-string
+ base-char integer simple-type-error
+ base-string keyword simple-vector
+ bignum list simple-warning
+ bit logical-pathname single-float
+ bit-vector long-float standard-char
+ broadcast-stream method standard-class
+ built-in-class method-combination standard-generic-function
+ cell-error nil standard-method
+ character null standard-object
+ class number storage-condition
+ compiled-function package stream
+ complex package-error stream-error
+ concatenated-stream parse-error string
+ condition pathname string-stream
+ cons print-not-readable structure-class
+ control-error program-error structure-object
+ division-by-zero random-state style-warning
+ double-float ratio symbol
+ echo-stream rational synonym-stream
+ end-of-file reader-error t
+ error readtable two-way-stream
+ extended-char real type-error
+ file-error restart unbound-slot
+ file-stream sequence unbound-variable
+ fixnum serious-condition undefined-function
+ float short-float unsigned-byte
+ floating-point-inexact signed-byte vector
+ floating-point-invalid-operation simple-array warning
+ floating-point-overflow simple-base-string
+ floating-point-underflow simple-bit-vector))
+
+(deftest test-basic-types-description-of ()
+ (let* ((symbol 'symbol)
+ (string "string")
+ (number 0)
+ (list (list symbol string number)))))
+
+
+
+
+
+
+
\ No newline at end of file
--- /dev/null
+(in-package :lisp-on-lines)
+
+(define-description description ())
+
+(defgeneric find-description-class (name &optional errorp)
+ (: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)))
+
+(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>")))))
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+(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 *object*)))
+ (with-active-layers (test-display)
+ (is (equalp "BRILLANT!" (display-using-description
+ (find-description 'attribute-test-2)
+ nil *object*))))))
+
\ No newline at end of file
--- /dev/null
+(in-package :lisp-on-lines)
+
+(defvar *object*)
+(defvar *display*)
+
+(define-layered-function display-using-description (description display object &rest args)
+ (:documentation
+ "Displays OBJECT via description using/in/with/on display"))
+
+(defun display (display object &rest args)
+ (display-using-description (description-of object) display object args))
+
+(define-layered-method display-using-description
+ :around (description display object &rest args)
+ (let ((*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)
+ 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."))
+ (return
+ (destructuring-bind (description-spec &optional (display-spec (gensym)) (object-spec (gensym)))
+ (car tail)
+ `(define-layered-method
+ display-using-description
+ :in-layer ,layer
+ ,@qualifiers
+ (,(if (listp description-spec)
+ (list (first description-spec)
+ (if (eq 'description (second description-spec))
+ 'description
+ (defining-description (second description-spec)))))
+ ,display-spec
+ ,object-spec &rest args)
+ (declare (ignorable args))
+ ,@(cdr tail))))))
+
+
+
+
\ No newline at end of file
HCoop / clinton / lisp-on-lines.git / commitdiff