HCoop Git - clinton/lisp-on-lines.git/blob

1 (in-package :lol-test)

3 (in-suite lisp-on-lines)

5 (deftest test-attribute-value ()

6 (eval

7 '(progn

8 (define-description attribute-test-description ()

        ((attribute-1 :value "VALUE")

         (attribute-2 :function (constantly "VALUE"))))

12 (define-description attribute-test)

14 (define-description attribute-test-description ()

        ((attribute-1 :value "VALUE2")

         (attribute-2 :function (constantly "VALUE2")))

17 (:in-description attribute-test))))

19 (funcall-with-described-object

20 (lambda (&aux

             (a1 (find-attribute *description* 'attribute-1))

             (a2 (find-attribute *description* 'attribute-2))

23 )

      (is (equalp "VALUE" (attribute-value a1)))

      (is (equalp "VALUE" (attribute-value a2)))

      (with-active-descriptions (attribute-test)

        (is (equalp "VALUE2" (attribute-value a1)))

        (is (equalp "VALUE2" (attribute-value a2)))))

29 nil

30 (find-description 'attribute-test-description)))

32 (deftest test-attribute-property-inheriting ()

33 (test-attribute-value)

34 (eval '(progn

35 (define-description attribute-property-test)

36 (define-description attribute-test-description ()

             ((attribute-1 :label "attribute1")

              (attribute-2 :label "attribute2"))

39 (:in-description attribute-property-test))))

   (with-active-descriptions (attribute-property-test)

     (with-described-object (nil (find-description 'attribute-test-description))

           (let ((d (dynamic description)))

                 (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))

         (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))

         (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))

         (with-active-descriptions (attribute-test)

           (is (equalp (attribute-value (find-attribute d 'attribute-1))

                       (attribute-value (find-attribute d 'attribute-2))))

           (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))

 (deftest (test-attribute-with-different-class :compile-before-run t) ()

57 (eval '(progn

58 (define-layered-class

59 test-attribute-class (standard-attribute)

60 ((some-slot :initarg :some-slot

61 :layered t

62 :special t

63 :layered-accessor some-slot)))

65 (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)

72 (find-class 'test-attribute-class)))

     (is (equalp "BRILLANT!" (some-slot a)))))

 (deftest (test-attribute-with-different-class-and-subclassed-description :compile-before-run t) ()

76 (test-attribute-with-different-class)

77 (eval '(progn

78 (define-description test-attribute-with-different-class-description-sub

79 (test-attribute-with-different-class-description)

80 ())))

   (let* ((d (find-description 'test-attribute-with-different-class-description-sub))

          (a (find-attribute d 'attribute-with-different-class)))

     (is (eq (class-of a)

86 (find-class 'test-attribute-class)))

     (is (equalp "BRILLANT!" (some-slot a)))))