From e7c5f95a989882cabc1f4b6ea4598565ea317952 Mon Sep 17 00:00:00 2001 From: drewc Date: Thu, 6 Sep 2007 17:29:04 -0700 Subject: [PATCH 1/1] Adding new implementation of LoL to repository. darcs-hash:20070907002904-39164-dc6735878421a3d5269cd0e78f4179d1618127d7.gz --- src/attribute-test.lisp | 54 ++++++++++++++++++++++ src/attribute.lisp | 86 +++++++++++++++++++++++++++++++++++ src/description-test.lisp | 95 +++++++++++++++++++++++++++++++++++++++ src/description.lisp | 75 +++++++++++++++++++++++++++++++ src/display-test.lisp | 21 +++++++++ src/display.lisp | 55 +++++++++++++++++++++++ 6 files changed, 386 insertions(+) create mode 100644 src/attribute-test.lisp create mode 100644 src/attribute.lisp create mode 100644 src/description-test.lisp create mode 100644 src/description.lisp create mode 100644 src/display-test.lisp create mode 100644 src/display.lisp diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp new file mode 100644 index 0000000..554b1a7 --- /dev/null +++ b/src/attribute-test.lisp @@ -0,0 +1,54 @@ +(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 diff --git a/src/attribute.lisp b/src/attribute.lisp new file mode 100644 index 0000000..2e3877e --- /dev/null +++ b/src/attribute.lisp @@ -0,0 +1,86 @@ +(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)))) + + + + + + + + + diff --git a/src/description-test.lisp b/src/description-test.lisp new file mode 100644 index 0000000..c42d672 --- /dev/null +++ b/src/description-test.lisp @@ -0,0 +1,95 @@ +(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 diff --git a/src/description.lisp b/src/description.lisp new file mode 100644 index 0000000..20362f8 --- /dev/null +++ b/src/description.lisp @@ -0,0 +1,75 @@ +(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) + ""))) + (package :function #'symbol-package + :label "Package:") + (function :label "Function:" + :function + (lambda (symbol) + (if (fboundp symbol) + (symbol-function symbol) + ""))))) + + + + + + + + + + + diff --git a/src/display-test.lisp b/src/display-test.lisp new file mode 100644 index 0000000..7bef6ef --- /dev/null +++ b/src/display-test.lisp @@ -0,0 +1,21 @@ +(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 diff --git a/src/display.lisp b/src/display.lisp new file mode 100644 index 0000000..91cbd06 --- /dev/null +++ b/src/display.lisp @@ -0,0 +1,55 @@ +(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 -- 2.20.1