src/attribute-test.lisp

   1 (in-package :lol-test)
   2
   3 (in-suite lisp-on-lines)
   4
   5 (deftest test-attribute-value ()
   6   (eval
   7    '(progn
   8      (define-description attribute-test-description ()
   9        ((attribute-1 :value "VALUE")
  10         (attribute-2 :function (constantly "VALUE"))))
  11
  12      (deflayer attribute-test)
  13
  14      (define-description attribute-test-description ()
  15        ((attribute-1 :value "VALUE2")
  16         (attribute-2 :function (constantly "VALUE2")))
  17        (:in-layer . attribute-test))))
  18
  19   (let ((d (find-description 'attribute-test-description)))
  20     (dletf (((described-object d) nil))
  21     (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
  22
  23     (with-active-layers (attribute-test)
  24       (is (equalp (attribute-value (find-attribute d 'attribute-1))
  25                   (attribute-value (find-attribute d 'attribute-2))))
  26       (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))))
  27
  28 (deftest test-attribute-property-inheriting ()
  29   (test-attribute-value)
  30   (eval '(progn
  31           (deflayer attribute-property-test)
  32           (define-description attribute-test-description ()
  33             ((attribute-1 :label "attribute1")
  34              (attribute-2 :label "attribute2"))
  35             (:in-layer . attribute-property-test))))
  36   (with-active-layers (attribute-property-test)
  37     (let ((d (find-description 'attribute-test-description)))
  38       (dletf (((described-object d) nil))
  39
  40         (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
  41
  42         (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
  43         (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
  44
  45
  46         (with-active-layers (attribute-test)
  47           (is (equalp (attribute-value (find-attribute d 'attribute-1))
  48                       (attribute-value (find-attribute d 'attribute-2))))
  49           (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))))
  50
  51 (deftest (test-attribute-with-different-class :compile-before-run t) ()
  52   (eval '(progn
  53           (define-layered-class
  54                 test-attribute-class (lol::standard-attribute)
  55                 ((some-slot :initarg :some-slot
  56                             :layered t
  57                             :layered-accessor some-slot)))
  58
  59           (define-description test-attribute-with-different-class-description ()
  60             ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))
  61
  62   (let* ((d (find-description 'test-attribute-with-different-class-description))
  63
  64          (a (find-attribute d 'attribute-with-different-class)))
  65     (is (eq (class-of a)
  66             (find-class 'test-attribute-class)))
  67     (is (equalp "BRILLANT!" (some-slot a)))))
  68
  69 (deftest (test-attribute-with-different-class-and-subclassed-description :compile-before-run t) ()
  70   (test-attribute-with-different-class)
  71   (eval '(progn
  72           (define-description test-attribute-with-different-class-description-sub
  73               (test-attribute-with-different-class-description)
  74             ())))
  75
  76   (let* ((d (find-description 'test-attribute-with-different-class-description-sub))
  77
  78          (a (find-attribute d 'attribute-with-different-class)))
  79     (is (eq (class-of a)
  80             (find-class 'test-attribute-class)))
  81     (is (equalp "BRILLANT!" (some-slot a)))))
  82
  83
  84
  85
  86
  87
  88