272 lines
13 KiB
EmacsLisp
272 lines
13 KiB
EmacsLisp
;;; ecss-schema-tests.el --- Immutable schema composition tests -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Geekinney
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'ecss)
|
|
|
|
(defun ecss-schema-test--definition (id &rest options)
|
|
"Return a complete schema definition for ID extended by OPTIONS."
|
|
(let ((definition (list :id id :initial nil :impacts '(paint))))
|
|
(while options
|
|
(setq definition (plist-put definition (pop options) (pop options))))
|
|
definition))
|
|
|
|
(defun ecss-schema-test--package (id definitions)
|
|
"Return immutable package ID built from DEFINITIONS."
|
|
(ecss-schema-package-create id definitions))
|
|
|
|
(ert-deftest ecss-schema-package-validates-identity-and-definitions ()
|
|
"Package and property identities have one strict grammar."
|
|
(dolist (id '(nil :app "app" 4))
|
|
(should-error
|
|
(ecss-schema-package-create id nil)
|
|
:type 'ecss-invalid-property-schema))
|
|
(dolist (definition
|
|
'((:id plain :impacts (paint))
|
|
(:id app/color :impacts nil)
|
|
(:id app/color :impacts (paint paint))
|
|
(:id app/color :impacts (paint) :aliases (:tone :tone))
|
|
(:id app/color :impacts (paint) :projections (tp tp))))
|
|
(should-error
|
|
(ecss-schema-package-create 'app (list definition))
|
|
:type 'ecss-invalid-property-schema))
|
|
(dolist
|
|
(definitions
|
|
'(((:id app/color :impacts (paint) :aliases (:tone))
|
|
(:id app/gap :impacts (geometry) :aliases (:tone)))
|
|
((:id app/color :impacts (paint) :aliases (app/gap))
|
|
(:id app/gap :impacts (geometry)))
|
|
((:id app/color :impacts (paint))
|
|
(:id app/gap :impacts (geometry) :aliases (app/color)))))
|
|
(should-error
|
|
(ecss-schema-package-create 'app definitions)
|
|
:type 'ecss-invalid-property-schema)))
|
|
|
|
(ert-deftest ecss-schema-package-copies-all-caller-owned-input ()
|
|
"Package creation snapshots mutable schema input exactly once."
|
|
(let* ((initial (vector (copy-sequence "red")))
|
|
(aliases (list :tone))
|
|
(impacts (list 'paint))
|
|
(projections (list 'tp))
|
|
(metadata-table
|
|
(let ((table (make-hash-table :test #'eq)))
|
|
(puthash 'role 'label table)
|
|
table))
|
|
(metadata (list :contexts (list 'text) :index metadata-table))
|
|
(definition
|
|
(list :id 'app/color :initial initial :aliases aliases
|
|
:impacts impacts :projections projections :metadata metadata))
|
|
(package (ecss-schema-package-create 'app (list definition)))
|
|
(schemas (ecss-schema-set-compose package)))
|
|
(aset (aref initial 0) 0 ?X)
|
|
(setcar aliases :damaged)
|
|
(setcar impacts 'geometry)
|
|
(setcar projections 'layout)
|
|
(setcar (plist-get metadata :contexts) 'box)
|
|
(puthash 'role 'damaged metadata-table)
|
|
(let ((property (ecss-schema-set-property schemas 'app/color)))
|
|
(should (equal ["red"] (ecss-property-schema-initial property)))
|
|
(should (equal '(:tone) (ecss-property-schema-aliases property)))
|
|
(should (equal '(paint) (ecss-property-schema-impacts property)))
|
|
(should (equal '(tp) (ecss-property-schema-projections property)))
|
|
(let ((stored (ecss-property-schema-metadata property)))
|
|
(should (equal '(text) (plist-get stored :contexts)))
|
|
(should (eq 'label (gethash 'role (plist-get stored :index))))))
|
|
(let ((canonical-metadata
|
|
(ecss-schema-set-property-metadata schemas 'app/color))
|
|
(alias-metadata
|
|
(ecss-schema-set-property-metadata schemas :tone)))
|
|
(should (equal (plist-get canonical-metadata :contexts)
|
|
(plist-get alias-metadata :contexts)))
|
|
(should (eq (gethash 'role (plist-get canonical-metadata :index))
|
|
(gethash 'role (plist-get alias-metadata :index))))
|
|
(setcar (plist-get canonical-metadata :contexts) 'damaged)
|
|
(puthash 'role 'damaged (plist-get canonical-metadata :index))
|
|
(let ((stored
|
|
(ecss-schema-set-property-metadata schemas 'app/color)))
|
|
(should (equal '(text) (plist-get stored :contexts)))
|
|
(should (eq 'label (gethash 'role (plist-get stored :index))))))))
|
|
|
|
(ert-deftest ecss-schema-set-compose-rejects-complete-collision-matrix ()
|
|
"Composition rejects package, canonical, and alias collisions atomically."
|
|
(let* ((left
|
|
(ecss-schema-test--package
|
|
'left (list (ecss-schema-test--definition
|
|
'left/color :aliases '(shared/tone)))))
|
|
(same-canonical
|
|
(ecss-schema-test--package
|
|
'right (list (ecss-schema-test--definition 'left/color))))
|
|
(canonical-over-alias
|
|
(ecss-schema-test--package
|
|
'right (list (ecss-schema-test--definition 'shared/tone))))
|
|
(alias-over-canonical
|
|
(ecss-schema-test--package
|
|
'right (list (ecss-schema-test--definition
|
|
'right/color :aliases '(left/color)))))
|
|
(same-alias
|
|
(ecss-schema-test--package
|
|
'right (list (ecss-schema-test--definition
|
|
'right/color :aliases '(shared/tone))))))
|
|
(should-error (ecss-schema-set-compose left left)
|
|
:type 'ecss-invalid-property-schema)
|
|
(dolist (right (list same-canonical canonical-over-alias
|
|
alias-over-canonical same-alias))
|
|
(should-error (ecss-schema-set-compose left right)
|
|
:type 'ecss-invalid-property-schema)
|
|
(should (equal '(left/color)
|
|
(ecss-schema-set-property-ids
|
|
(ecss-schema-set-compose left))))
|
|
(should (= 1 (length (ecss-schema-package-property-ids right)))))))
|
|
|
|
(ert-deftest ecss-schema-set-exposes-immutable-composition-index ()
|
|
"Composed package order, canonical lookup, and schemas are deterministic."
|
|
(let* ((app
|
|
(ecss-schema-test--package
|
|
'app (list (ecss-schema-test--definition
|
|
'app/color :aliases '(:tone)))))
|
|
(ui
|
|
(ecss-schema-test--package
|
|
'ui (list (ecss-schema-test--definition 'ui/gap))))
|
|
(schemas (ecss-schema-set-compose app ui))
|
|
(ids (ecss-schema-set-property-ids schemas))
|
|
(packages (ecss-schema-set-package-ids schemas))
|
|
(property (ecss-schema-set-property schemas :tone)))
|
|
(should (eq 'app (ecss-schema-package-id app)))
|
|
(should (equal '(app/color) (ecss-schema-package-property-ids app)))
|
|
(should (equal '(app ui) packages))
|
|
(should (equal '(app/color ui/gap) ids))
|
|
(should (eq 'app/color (ecss-schema-set-canonical-id schemas :tone)))
|
|
(should (eq 'app/color (ecss-property-schema-id property)))
|
|
(should (eq 'app (ecss-property-schema-owner property)))
|
|
(setcar ids 'damaged)
|
|
(setcar packages 'damaged)
|
|
(setf (ecss-property-schema-owner property) 'damaged)
|
|
(should (equal '(app ui) (ecss-schema-set-package-ids schemas)))
|
|
(should (equal '(app/color ui/gap)
|
|
(ecss-schema-set-property-ids schemas)))
|
|
(should (eq 'app
|
|
(ecss-property-schema-owner
|
|
(ecss-schema-set-property schemas 'app/color))))))
|
|
|
|
(ert-deftest ecss-schema-aliases-disappear-before-cascade ()
|
|
"Alias declarations normalize to canonical property identifiers."
|
|
(let* ((package
|
|
(ecss-schema-test--package
|
|
'app
|
|
(list (ecss-schema-test--definition
|
|
'app/color :initial "black" :aliases '(:tone)
|
|
:validator #'stringp))))
|
|
(schemas (ecss-schema-set-compose package))
|
|
(expanded (ecss-expand-declarations schemas '(:tone "red")))
|
|
(style (ecss-compute-style
|
|
schemas (ecss-subject-create :type "box")
|
|
:declarations '(:tone "red") :provenance t)))
|
|
(should (equal '(app/color "red") expanded))
|
|
(should (equal '(app/color "red")
|
|
(ecss-computed-style-values style)))
|
|
(should (equal "red" (ecss-computed-style-value style :tone)))
|
|
(should (ecss-property-equal-p schemas :tone "red" "red"))
|
|
(dolist (declarations
|
|
'((:tone "red" app/color "blue")
|
|
(:tone "red" :tone "blue")))
|
|
(should-error
|
|
(ecss-expand-declarations schemas declarations)
|
|
:type 'ecss-invalid-declaration))))
|
|
|
|
(ert-deftest ecss-schema-shorthand-conflicts-with-owned-longhand ()
|
|
"One declaration source cannot produce the same canonical output twice."
|
|
(let* ((package
|
|
(ecss-schema-test--package
|
|
'app
|
|
(list
|
|
(ecss-schema-test--definition 'app/top)
|
|
(ecss-schema-test--definition
|
|
'app/padding
|
|
:shorthand (lambda (value) (list 'app/top value))))))
|
|
(schemas (ecss-schema-set-compose package)))
|
|
(should-error
|
|
(ecss-expand-declarations
|
|
schemas '(app/padding 1 app/top 2))
|
|
:type 'ecss-invalid-declaration)
|
|
(should (equal '(app/top 2)
|
|
(ecss-merge-declarations
|
|
schemas '(app/padding 1) '(app/top 2))))))
|
|
|
|
(ert-deftest ecss-computed-property-fact-shares-value-and-multi-impact ()
|
|
"One typed fact carries value, provenance, and every declared impact."
|
|
(let* ((metadata (list :contexts '(text box)))
|
|
(package
|
|
(ecss-schema-test--package
|
|
'app
|
|
(list (ecss-schema-test--definition
|
|
'app/font :initial nil :impacts '(geometry paint)
|
|
:projections '(measure tp) :metadata metadata))))
|
|
(schemas (ecss-schema-set-compose package))
|
|
(value (list :family "Mono"))
|
|
(style (ecss-compute-style
|
|
schemas (ecss-subject-create :type "text")
|
|
:declarations (list 'app/font value) :provenance t))
|
|
(fact (ecss-computed-style-property-fact style 'app/font))
|
|
(original-provenance
|
|
(copy-tree (ecss-computed-property-fact-provenance fact))))
|
|
(should (ecss-computed-property-fact-p fact))
|
|
(should (equal (ecss-computed-property-fact-value fact)
|
|
(ecss-computed-style-value style 'app/font)))
|
|
(should (equal '(geometry paint)
|
|
(ecss-computed-property-fact-impacts fact)))
|
|
(should (equal '(measure tp)
|
|
(ecss-computed-property-fact-projections fact)))
|
|
(should (eq 'app (ecss-computed-property-fact-owner fact)))
|
|
(should (plist-get (ecss-computed-property-fact-provenance fact) :source))
|
|
(should (equal (ecss-computed-property-fact-metadata fact)
|
|
(ecss-schema-set-property-metadata schemas 'app/font)))
|
|
(let* ((fact-value (ecss-computed-property-fact-value fact))
|
|
(geometry-value fact-value)
|
|
(paint-value fact-value)
|
|
(impacts (ecss-computed-property-fact-impacts fact))
|
|
(projections (ecss-computed-property-fact-projections fact))
|
|
(provenance (ecss-computed-property-fact-provenance fact))
|
|
(fact-metadata (ecss-computed-property-fact-metadata fact)))
|
|
(setcar fact-value :damaged-value)
|
|
(setcar impacts 'damaged-impact)
|
|
(setcar projections 'damaged-projection)
|
|
(setcar provenance :damaged)
|
|
(setcar (plist-get fact-metadata :contexts) 'damaged-context)
|
|
(let ((fresh (ecss-computed-style-property-fact style 'app/font)))
|
|
(should (eq geometry-value paint-value))
|
|
(should (equal '(:family "Mono")
|
|
(ecss-computed-property-fact-value fresh)))
|
|
(should (equal '(:family "Mono")
|
|
(ecss-computed-style-value style 'app/font)))
|
|
(should (equal '(geometry paint)
|
|
(ecss-computed-property-fact-impacts fresh)))
|
|
(should (equal '(measure tp)
|
|
(ecss-computed-property-fact-projections fresh)))
|
|
(should (plist-get
|
|
(ecss-computed-property-fact-provenance fresh) :source))
|
|
(should (equal '(text box)
|
|
(plist-get
|
|
(ecss-computed-property-fact-metadata fresh)
|
|
:contexts)))))
|
|
(let* ((replacement (list :family "Serif"))
|
|
(copy (ecss-computed-style-copy-with-values
|
|
style (list 'app/font replacement)))
|
|
(copy-fact
|
|
(ecss-computed-style-property-fact copy 'app/font)))
|
|
(should (equal replacement
|
|
(ecss-computed-style-value copy 'app/font)))
|
|
(should (equal (ecss-computed-property-fact-value copy-fact)
|
|
(ecss-computed-style-value copy 'app/font)))
|
|
(should (equal original-provenance
|
|
(ecss-computed-property-fact-provenance copy-fact)))
|
|
(should (equal '(geometry paint)
|
|
(ecss-computed-property-fact-impacts copy-fact))))))
|
|
|
|
(provide 'ecss-schema-tests)
|
|
|
|
;;; ecss-schema-tests.el ends here
|