refactor: compose immutable property schemas per surface
This commit is contained in:
parent
88b23b5f80
commit
c79eb796b4
19
README.en.md
19
README.en.md
@ -13,12 +13,15 @@ This repository is a new lowercase `ecss` project. It neither modifies nor depen
|
|||||||
```elisp
|
```elisp
|
||||||
(require 'ecss)
|
(require 'ecss)
|
||||||
|
|
||||||
(let ((schemas (ecss-schema-set-create))
|
(let* ((package
|
||||||
(sheet (ecss-stylesheet-create))
|
(ecss-schema-package-create
|
||||||
(button (ecss-subject-create
|
'demo
|
||||||
:type "button" :classes '("primary"))))
|
'((:id demo/color :initial "black" :inherits t
|
||||||
(ecss-schema-set-define
|
:validator stringp :aliases (:color) :impacts (paint)))))
|
||||||
schemas 'demo/color :initial "black" :inherits t :validator #'stringp)
|
(schemas (ecss-schema-set-compose package))
|
||||||
|
(sheet (ecss-stylesheet-create))
|
||||||
|
(button (ecss-subject-create
|
||||||
|
:type "button" :classes '("primary"))))
|
||||||
(ecss-stylesheet-add-rule
|
(ecss-stylesheet-add-rule
|
||||||
sheet schemas "button.primary" '(demo/color "royalblue"))
|
sheet schemas "button.primary" '(demo/color "royalblue"))
|
||||||
(ecss-computed-style-value
|
(ecss-computed-style-value
|
||||||
@ -30,9 +33,9 @@ This repository is a new lowercase `ecss` project. It neither modifies nor depen
|
|||||||
## Core boundary
|
## Core boundary
|
||||||
|
|
||||||
- `ecss-selector.el` owns the selector AST, parser, matcher, specificity, and generic subject adapter.
|
- `ecss-selector.el` owns the selector AST, parser, matcher, specificity, and generic subject adapter.
|
||||||
- `ecss-cascade.el` owns explicit schema sets, stylesheets, complete winner ordering, inheritance, variable resolution, and provenance.
|
- `ecss-cascade.el` owns immutable package schemas, surface schema sets, stylesheets, complete winner ordering, inheritance, variable resolution, and provenance.
|
||||||
- `ecss.el` is the public package facade and has no behavioral load side effects.
|
- `ecss.el` is the public package facade and has no behavioral load side effects.
|
||||||
- Schema sets and stylesheets change only through explicit authoring APIs. `ecss-compute-style` mutates neither its inputs nor the current buffer.
|
- Package schemas and composed schema sets are immutable. Stylesheets change only through explicit authoring APIs. `ecss-compute-style` mutates neither its inputs nor the current buffer.
|
||||||
- An ordinary function value always remains a value. ECSS calls code only through an explicitly supplied `:value-resolver`; ECSS itself knows nothing about TP bindings, Ebox nodes, or consumer-specific value-source types.
|
- An ordinary function value always remains a value. ECSS calls code only through an explicitly supplied `:value-resolver`; ECSS itself knows nothing about TP bindings, Ebox nodes, or consumer-specific value-source types.
|
||||||
|
|
||||||
See [Architecture](docs/architecture.en.md) and [API Reference](docs/api.en.md) for the complete contract.
|
See [Architecture](docs/architecture.en.md) and [API Reference](docs/api.en.md) for the complete contract.
|
||||||
|
|||||||
19
README.md
19
README.md
@ -13,12 +13,15 @@
|
|||||||
```elisp
|
```elisp
|
||||||
(require 'ecss)
|
(require 'ecss)
|
||||||
|
|
||||||
(let ((schemas (ecss-schema-set-create))
|
(let* ((package
|
||||||
(sheet (ecss-stylesheet-create))
|
(ecss-schema-package-create
|
||||||
(button (ecss-subject-create
|
'demo
|
||||||
:type "button" :classes '("primary"))))
|
'((:id demo/color :initial "black" :inherits t
|
||||||
(ecss-schema-set-define
|
:validator stringp :aliases (:color) :impacts (paint)))))
|
||||||
schemas 'demo/color :initial "black" :inherits t :validator #'stringp)
|
(schemas (ecss-schema-set-compose package))
|
||||||
|
(sheet (ecss-stylesheet-create))
|
||||||
|
(button (ecss-subject-create
|
||||||
|
:type "button" :classes '("primary"))))
|
||||||
(ecss-stylesheet-add-rule
|
(ecss-stylesheet-add-rule
|
||||||
sheet schemas "button.primary" '(demo/color "royalblue"))
|
sheet schemas "button.primary" '(demo/color "royalblue"))
|
||||||
(ecss-computed-style-value
|
(ecss-computed-style-value
|
||||||
@ -30,9 +33,9 @@
|
|||||||
## 核心边界
|
## 核心边界
|
||||||
|
|
||||||
- `ecss-selector.el`:selector AST/parser/matcher/specificity 与通用 subject adapter。
|
- `ecss-selector.el`:selector AST/parser/matcher/specificity 与通用 subject adapter。
|
||||||
- `ecss-cascade.el`:显式 schema set、stylesheet、完整 winner 顺序、继承、变量解析和 provenance。
|
- `ecss-cascade.el`:不可变 package schema、surface schema set、stylesheet、完整 winner 顺序、继承、变量解析和 provenance。
|
||||||
- `ecss.el`:公开 package facade;加载时没有行为副作用。
|
- `ecss.el`:公开 package facade;加载时没有行为副作用。
|
||||||
- schema set 和 stylesheet 只在显式 authoring API 中修改;`ecss-compute-style` 不修改输入对象或当前 Buffer。
|
- package schema 与组合后的 schema set 不可变;stylesheet 只由显式 authoring API 修改;`ecss-compute-style` 不修改输入对象或当前 Buffer。
|
||||||
- 普通 function value 永远是普通值。只有调用者显式传入 `:value-resolver` 时,ECSS 才调用该 resolver;ECSS 自己不认识 TP binding、Ebox node 或任何业务 value-source 类型。
|
- 普通 function value 永远是普通值。只有调用者显式传入 `:value-resolver` 时,ECSS 才调用该 resolver;ECSS 自己不认识 TP binding、Ebox node 或任何业务 value-source 类型。
|
||||||
|
|
||||||
详细设计见 [架构](docs/architecture.zh.md) 与 [API 参考](docs/api.zh.md)。
|
详细设计见 [架构](docs/architecture.zh.md) 与 [API 参考](docs/api.zh.md)。
|
||||||
|
|||||||
@ -4,14 +4,19 @@
|
|||||||
|
|
||||||
## Schemas
|
## Schemas
|
||||||
|
|
||||||
- `(ecss-schema-set-create)` creates an isolated registry.
|
- `(ecss-schema-package-create PACKAGE-ID DEFINITIONS)` validates and snapshots one package's property definitions.
|
||||||
- `(ecss-schema-set-define SCHEMAS ID &rest OPTIONS)` atomically registers a namespaced property. OPTIONS are `:initial`, `:inherits`, `:normalizer`, `:validator`, `:equality`, and `:shorthand`.
|
- `(ecss-schema-package-id PACKAGE)` and `(ecss-schema-package-property-ids PACKAGE)` return detached identity/index data.
|
||||||
- `(ecss-schema-set-property SCHEMAS ID)` returns a defensive schema copy.
|
- `(ecss-schema-set-compose &rest PACKAGES)` atomically composes one surface's immutable schema set. A package, canonical, or alias collision rejects the whole composition.
|
||||||
- `(ecss-schema-set-property-ids SCHEMAS)` returns stable registration order.
|
- `(ecss-schema-set-package-ids SCHEMAS)` and `(ecss-schema-set-property-ids SCHEMAS)` return stable composition order.
|
||||||
|
- `(ecss-schema-set-canonical-id SCHEMAS NAME)` resolves an exact alias to its canonical ID.
|
||||||
|
- `(ecss-schema-set-property SCHEMAS ID)` returns a defensive schema copy for a canonical ID or exact alias.
|
||||||
|
- `(ecss-schema-set-property-metadata SCHEMAS ID)` returns detached metadata.
|
||||||
- `(ecss-expand-declarations SCHEMAS DECLARATIONS)` validates properties and expands each shorthand once.
|
- `(ecss-expand-declarations SCHEMAS DECLARATIONS)` validates properties and expands each shorthand once.
|
||||||
- `(ecss-merge-declarations SCHEMAS &rest DECLARATION-GROUPS)` expands and merges groups from left to right. Later groups replace the same longhand, while explicit nil remains a declaration.
|
- `(ecss-merge-declarations SCHEMAS &rest DECLARATION-GROUPS)` expands and merges groups from left to right. Later groups replace the same longhand, while explicit nil remains a declaration.
|
||||||
|
|
||||||
A property ID is a symbol containing `/`, such as `demo/color`. Custom properties need no schema and use `--name` symbols. `initial` is normalized and validated once at schema registration; already computed initial and inherited values do not run the normalizer again.
|
Each definition is a plist containing `:id`, a nonempty `:impacts`, and optional `:initial`, `:inherits`, `:normalizer`, `:validator`, `:equality`, `:shorthand`, `:aliases`, `:projections`, and `:metadata`. A property ID is a symbol containing `/`, such as `demo/color`. Aliases exist only at declaration normalization. Canonical/alias, duplicate-alias, and shorthand/owned-longhand conflicts in one declaration are errors rather than implicit last-wins; later declaration groups still replace earlier groups.
|
||||||
|
|
||||||
|
Custom properties need no schema and use `--name` symbols. `initial` is normalized and validated once when the package is created; already computed initial and inherited values do not run the normalizer again. Packages and composed schema sets expose no mutator.
|
||||||
|
|
||||||
## Subjects and selectors
|
## Subjects and selectors
|
||||||
|
|
||||||
@ -52,8 +57,9 @@ Do not pass both `:stylesheet` and `:rules`. `:rules` accepts the rule list retu
|
|||||||
- `(ecss-computed-style-copy-with-values STYLE VALUES &key active-properties specified-properties)` returns an immutable-style copy for a consumer that has already proved selector/cascade facts unchanged and only needs to replace computed values.
|
- `(ecss-computed-style-copy-with-values STYLE VALUES &key active-properties specified-properties)` returns an immutable-style copy for a consumer that has already proved selector/cascade facts unchanged and only needs to replace computed values.
|
||||||
- `(ecss-computed-style-provenance STYLE)` returns winner, origin, importance, layer, specificity, scope/source/declaration order, validity, and fallback facts.
|
- `(ecss-computed-style-provenance STYLE)` returns winner, origin, importance, layer, specificity, scope/source/declaration order, validity, and fallback facts.
|
||||||
- `(ecss-computed-style-diagnostics STYLE)` returns deterministic diagnostics such as custom-property cycles.
|
- `(ecss-computed-style-diagnostics STYLE)` returns deterministic diagnostics such as custom-property cycles.
|
||||||
- `(ecss-computed-style-value STYLE PROPERTY &optional FALLBACK)` reads one value.
|
- `(ecss-computed-style-value STYLE PROPERTY &optional FALLBACK)` reads one detached value; PROPERTY may be canonical or an exact alias.
|
||||||
|
- `(ecss-computed-style-property-fact STYLE PROPERTY)` returns one detached typed fact containing the canonical property, computed value, owner, impact set, projections, winner provenance, and metadata. The same fact can be routed to multiple impact consumers without normalizing its value again.
|
||||||
- `(ecss-computed-style-present-p STYLE PROPERTY)` detects an active property even when its value is nil.
|
- `(ecss-computed-style-present-p STYLE PROPERTY)` detects an active property even when its value is nil.
|
||||||
- `(ecss-computed-style-specified-p STYLE PROPERTY)` detects whether a longhand property has a cascade winner.
|
- `(ecss-computed-style-specified-p STYLE PROPERTY)` detects whether a longhand property has a cascade winner.
|
||||||
|
|
||||||
Every aggregate getter returns a defensive copy. Mutating a returned value cannot change a computed style, schema set, or stylesheet.
|
No public schema or computed getter exposes a mutable registry or computed-style object. Mutating a returned value cannot change a computed style, schema set, or stylesheet.
|
||||||
|
|||||||
@ -4,14 +4,19 @@
|
|||||||
|
|
||||||
## Schema
|
## Schema
|
||||||
|
|
||||||
- `(ecss-schema-set-create)` 创建隔离 registry。
|
- `(ecss-schema-package-create PACKAGE-ID DEFINITIONS)` 一次校验并快照一个 package 的属性定义。
|
||||||
- `(ecss-schema-set-define SCHEMAS ID &rest OPTIONS)` 原子注册 namespaced property。OPTIONS 是 `:initial`、`:inherits`、`:normalizer`、`:validator`、`:equality`、`:shorthand`。
|
- `(ecss-schema-package-id PACKAGE)` 与 `(ecss-schema-package-property-ids PACKAGE)` 返回 detached identity/index 信息。
|
||||||
- `(ecss-schema-set-property SCHEMAS ID)` 返回 defensive schema copy。
|
- `(ecss-schema-set-compose &rest PACKAGES)` 原子组合一个 surface 的不可变 schema set;package、canonical 与 alias 冲突都会使整次组合失败。
|
||||||
- `(ecss-schema-set-property-ids SCHEMAS)` 返回稳定注册顺序。
|
- `(ecss-schema-set-package-ids SCHEMAS)` 与 `(ecss-schema-set-property-ids SCHEMAS)` 返回稳定组合顺序。
|
||||||
|
- `(ecss-schema-set-canonical-id SCHEMAS NAME)` 把 exact alias 解析为 canonical ID。
|
||||||
|
- `(ecss-schema-set-property SCHEMAS ID)` 返回 defensive schema copy;`ID` 可以是 canonical 或 exact alias。
|
||||||
|
- `(ecss-schema-set-property-metadata SCHEMAS ID)` 返回 detached metadata。
|
||||||
- `(ecss-expand-declarations SCHEMAS DECLARATIONS)` 校验属性并只展开一次 shorthand。
|
- `(ecss-expand-declarations SCHEMAS DECLARATIONS)` 校验属性并只展开一次 shorthand。
|
||||||
- `(ecss-merge-declarations SCHEMAS &rest DECLARATION-GROUPS)` 按从左到右的优先级展开并合并多组声明;后组覆盖相同 longhand,显式 nil 不会被当作缺省。
|
- `(ecss-merge-declarations SCHEMAS &rest DECLARATION-GROUPS)` 按从左到右的优先级展开并合并多组声明;后组覆盖相同 longhand,显式 nil 不会被当作缺省。
|
||||||
|
|
||||||
Property ID 必须是包含 `/` 的 symbol,例如 `demo/color`。Custom property 不需要 schema,使用 `--name` symbol。`initial` 在 schema 注册时规范化并校验一次;已计算的 initial/inherited value 不会再次执行 normalizer。
|
每个 definition 是包含 `:id`、非空 `:impacts`,以及可选 `:initial`、`:inherits`、`:normalizer`、`:validator`、`:equality`、`:shorthand`、`:aliases`、`:projections`、`:metadata` 的 plist。Property ID 必须是包含 `/` 的 symbol,例如 `demo/color`。Alias 只存在于声明归一化入口;同一声明中 canonical/alias、重复 alias 或 shorthand/owned-longhand 冲突会报错,不采用隐式 last-wins。不同 declaration group 仍由后组覆盖前组。
|
||||||
|
|
||||||
|
Custom property 不需要 schema,使用 `--name` symbol。`initial` 在 package 创建时规范化并校验一次;已计算的 initial/inherited value 不会再次执行 normalizer。Package 与组合后的 schema set 没有公共 mutator。
|
||||||
|
|
||||||
## Subject 与 selector
|
## Subject 与 selector
|
||||||
|
|
||||||
@ -52,8 +57,9 @@ ORIGIN 是 `ua`、`user`、`author`、`animation` 或 `transition`。Inline decl
|
|||||||
- `(ecss-computed-style-copy-with-values STYLE VALUES &key active-properties specified-properties)` 在 selector/cascade 事实已证明不变、只需替换 computed values 时返回新的 immutable-style copy。
|
- `(ecss-computed-style-copy-with-values STYLE VALUES &key active-properties specified-properties)` 在 selector/cascade 事实已证明不变、只需替换 computed values 时返回新的 immutable-style copy。
|
||||||
- `(ecss-computed-style-provenance STYLE)` 返回 winner、origin、important、layer、specificity、scope/source/declaration order、valid/fallback 等事实。
|
- `(ecss-computed-style-provenance STYLE)` 返回 winner、origin、important、layer、specificity、scope/source/declaration order、valid/fallback 等事实。
|
||||||
- `(ecss-computed-style-diagnostics STYLE)` 返回 custom-property cycle 等 deterministic diagnostics。
|
- `(ecss-computed-style-diagnostics STYLE)` 返回 custom-property cycle 等 deterministic diagnostics。
|
||||||
- `(ecss-computed-style-value STYLE PROPERTY &optional FALLBACK)` 读取单值。
|
- `(ecss-computed-style-value STYLE PROPERTY &optional FALLBACK)` 读取 detached 单值;PROPERTY 可以是 canonical 或 exact alias。
|
||||||
|
- `(ecss-computed-style-property-fact STYLE PROPERTY)` 返回一个 detached typed fact,包含 canonical property、computed value、owner、impact set、projections、winner provenance 与 metadata。同一个 fact 可同时交给多个 impact consumer,不重新规范化其 value。
|
||||||
- `(ecss-computed-style-present-p STYLE PROPERTY)` 判断 property 是否 active,即使值为 nil。
|
- `(ecss-computed-style-present-p STYLE PROPERTY)` 判断 property 是否 active,即使值为 nil。
|
||||||
- `(ecss-computed-style-specified-p STYLE PROPERTY)` 判断长手 property 是否存在 cascade winner。
|
- `(ecss-computed-style-specified-p STYLE PROPERTY)` 判断长手 property 是否存在 cascade winner。
|
||||||
|
|
||||||
所有 aggregate getter 都返回 defensive copy。调用者修改返回值不会改变 computed style、schema set 或 stylesheet。
|
所有公共 schema/computed getter 都不会暴露 registry 或 computed style 的可变内部对象。调用者修改返回值不会改变 computed style、schema set 或 stylesheet。
|
||||||
|
|||||||
@ -21,9 +21,13 @@ consumer schemas + subject adapter + stylesheet + parent style
|
|||||||
|
|
||||||
`ecss` does not know how computed values are displayed. TP may convert final text-property contributions into retained surface patches. Ebox may interpret final Box/Flex/Grid properties as measurement, layout, and painting consequences. Ordinary callers may use `ecss` without either package.
|
`ecss` does not know how computed values are displayed. TP may convert final text-property contributions into retained surface patches. Ebox may interpret final Box/Flex/Grid properties as measurement, layout, and painting consequences. Ordinary callers may use `ecss` without either package.
|
||||||
|
|
||||||
## Explicit objects instead of process-global state
|
## Package schemas and explicit surfaces
|
||||||
|
|
||||||
Each consumer creates its own `ecss-schema-set` and `ecss-stylesheet`. Two applications can use the same selector tokens, different property vocabularies, and different layer orders in one Emacs process without interference. UA, user, and author origins inside one stylesheet also keep independent layer orders. Schema registration and rule addition are explicit atomic authoring operations. Failure cannot leave a partial schema, a half-added layer, or an incorrect source order.
|
Each owning package creates one immutable `ecss-schema-package`. A concrete surface then atomically composes the required packages with `ecss-schema-set-compose`. Composition rejects duplicate packages and canonical/canonical, canonical/alias, and alias/alias collisions. There is no process-global mutable registry and no last-wins registration, so applications can compose different property vocabularies in one Emacs process without interference.
|
||||||
|
|
||||||
|
Aliases exist only at declaration normalization and disappear before cascade. An alias/canonical duplicate or a shorthand/owned-longhand conflict inside one declaration fails immediately. The schema set retains owner, impact, and projection facts, and a computed style references that set instead of building a second computed tree. Packages and schema sets expose no mutator; public queries return detached data.
|
||||||
|
|
||||||
|
Stylesheets remain explicitly owned mutable authoring objects. UA, user, and author origins inside one stylesheet keep independent layer orders. Rule addition is atomic, so failure cannot leave a half-added layer or an incorrect source order.
|
||||||
|
|
||||||
## Subjects and adapters
|
## Subjects and adapters
|
||||||
|
|
||||||
|
|||||||
@ -21,9 +21,13 @@ consumer schemas + subject adapter + stylesheet + parent style
|
|||||||
|
|
||||||
`ecss` 不知道 computed values 最终如何显示。TP 可以把最终文本属性贡献转换成 retained surface patch;Ebox 可以把最终 Box/Flex/Grid 属性解释成 measurement、layout 与 painting 后果;普通调用者也可以完全不用 TP/Ebox。
|
`ecss` 不知道 computed values 最终如何显示。TP 可以把最终文本属性贡献转换成 retained surface patch;Ebox 可以把最终 Box/Flex/Grid 属性解释成 measurement、layout 与 painting 后果;普通调用者也可以完全不用 TP/Ebox。
|
||||||
|
|
||||||
## 显式对象而不是进程全局状态
|
## Package schema 与显式 surface
|
||||||
|
|
||||||
每个 consumer 创建自己的 `ecss-schema-set` 与 `ecss-stylesheet`。两个应用可以在同一 Emacs 中使用同名 selector token、不同 property vocabulary 和不同 layer 顺序而互不污染;同一 stylesheet 中的 UA、user 与 author origin 也分别维护自己的 layer order。schema 注册与 rule 添加是显式、原子的 authoring 操作;一次失败不会留下半注册 schema、半添加 layer 或错误 source order。
|
每个 owning package 一次创建不可变 `ecss-schema-package`;具体 surface 再用 `ecss-schema-set-compose` 原子组合所需 package。组合阶段统一拒绝重复 package、canonical/canonical、canonical/alias 与 alias/alias 冲突,不存在进程全局 mutable registry 或 last-wins 注册。两个应用因此可以在同一 Emacs 中组合不同 property vocabulary 而互不污染。
|
||||||
|
|
||||||
|
Alias 只属于声明归一化入口,进入 cascade 前消失;同一声明中 alias/canonical 重复或 shorthand 与其输出 longhand 冲突会立即失败。Schema set 同时保存 owner、impact 与 projection facts,computed style 直接引用该 set,不建立第二棵 computed tree。Package/schema set 不提供 mutator,公共查询返回 detached 数据。
|
||||||
|
|
||||||
|
Stylesheet 仍是每个调用者显式拥有的可变 authoring 对象。同一 stylesheet 中的 UA、user 与 author origin 分别维护 layer order;rule 添加是原子的,一次失败不会留下半添加 layer 或错误 source order。
|
||||||
|
|
||||||
## Subject 与 adapter
|
## Subject 与 adapter
|
||||||
|
|
||||||
|
|||||||
338
ecss-cascade.el
338
ecss-cascade.el
@ -25,13 +25,20 @@
|
|||||||
(cl-defstruct (ecss-property-schema
|
(cl-defstruct (ecss-property-schema
|
||||||
(:constructor ecss--make-property-schema))
|
(:constructor ecss--make-property-schema))
|
||||||
"Schema governing one namespaced cascade property."
|
"Schema governing one namespaced cascade property."
|
||||||
id initial inherits normalizer validator equality shorthand)
|
id owner initial inherits normalizer validator equality shorthand
|
||||||
|
aliases impacts projections metadata)
|
||||||
|
|
||||||
|
(cl-defstruct (ecss-schema-package
|
||||||
|
(:constructor ecss--make-schema-package)
|
||||||
|
(:conc-name ecss--schema-package-))
|
||||||
|
"Immutable property schema registry owned by one package."
|
||||||
|
id table order)
|
||||||
|
|
||||||
(cl-defstruct (ecss-schema-set
|
(cl-defstruct (ecss-schema-set
|
||||||
(:constructor ecss--make-schema-set)
|
(:constructor ecss--make-schema-set)
|
||||||
(:conc-name ecss--schema-set-))
|
(:conc-name ecss--schema-set-))
|
||||||
"Explicit registry of consumer-owned property schemas."
|
"Immutable composition of package-owned property schemas."
|
||||||
table order)
|
package-ids table aliases order)
|
||||||
|
|
||||||
(cl-defstruct (ecss-stylesheet
|
(cl-defstruct (ecss-stylesheet
|
||||||
(:constructor ecss--make-stylesheet)
|
(:constructor ecss--make-stylesheet)
|
||||||
@ -47,9 +54,20 @@
|
|||||||
(:constructor ecss--make-computed-style)
|
(:constructor ecss--make-computed-style)
|
||||||
(:conc-name ecss--computed-style-))
|
(:conc-name ecss--computed-style-))
|
||||||
"Computed declarations, custom properties, metadata, and diagnostics."
|
"Computed declarations, custom properties, metadata, and diagnostics."
|
||||||
values custom-properties active-properties specified-properties
|
schemas values custom-properties active-properties specified-properties
|
||||||
provenance diagnostics)
|
provenance diagnostics)
|
||||||
|
|
||||||
|
(cl-defstruct (ecss-computed-property-fact
|
||||||
|
(:constructor ecss--make-computed-property-fact))
|
||||||
|
"One detached typed value with its package-owned schema facts."
|
||||||
|
(property nil :read-only t)
|
||||||
|
(value nil :read-only t)
|
||||||
|
(owner nil :read-only t)
|
||||||
|
(impacts nil :read-only t)
|
||||||
|
(projections nil :read-only t)
|
||||||
|
(provenance nil :read-only t)
|
||||||
|
(metadata nil :read-only t))
|
||||||
|
|
||||||
(cl-defstruct (ecss--wide (:constructor ecss--make-wide)) kind)
|
(cl-defstruct (ecss--wide (:constructor ecss--make-wide)) kind)
|
||||||
(cl-defstruct (ecss--important (:constructor ecss--make-important)) value)
|
(cl-defstruct (ecss--important (:constructor ecss--make-important)) value)
|
||||||
(cl-defstruct (ecss--var-ref (:constructor ecss--make-var-ref))
|
(cl-defstruct (ecss--var-ref (:constructor ecss--make-var-ref))
|
||||||
@ -60,8 +78,9 @@
|
|||||||
scope-distance source-order declaration-order selector)
|
scope-distance source-order declaration-order selector)
|
||||||
|
|
||||||
(defconst ecss--schema-option-keys
|
(defconst ecss--schema-option-keys
|
||||||
'(:initial :inherits :normalizer :validator :equality :shorthand)
|
'(:id :initial :inherits :normalizer :validator :equality :shorthand
|
||||||
"Accepted property schema option keys.")
|
:aliases :impacts :projections :metadata)
|
||||||
|
"Accepted keys in one package property definition.")
|
||||||
|
|
||||||
(defconst ecss--origins '(ua user author animation transition)
|
(defconst ecss--origins '(ua user author animation transition)
|
||||||
"Supported standard CSS cascade origins.")
|
"Supported standard CSS cascade origins.")
|
||||||
@ -72,10 +91,6 @@
|
|||||||
(defconst ecss--invalid (make-symbol "ecss-invalid-value"))
|
(defconst ecss--invalid (make-symbol "ecss-invalid-value"))
|
||||||
(defconst ecss--absent (make-symbol "ecss-absent-value"))
|
(defconst ecss--absent (make-symbol "ecss-absent-value"))
|
||||||
|
|
||||||
(defun ecss-schema-set-create ()
|
|
||||||
"Create an empty independent property schema set."
|
|
||||||
(ecss--make-schema-set :table (make-hash-table :test #'eq) :order nil))
|
|
||||||
|
|
||||||
(defun ecss--schema-set-check (schemas)
|
(defun ecss--schema-set-check (schemas)
|
||||||
"Return SCHEMAS or signal when it is not a schema set."
|
"Return SCHEMAS or signal when it is not a schema set."
|
||||||
(unless (ecss-schema-set-p schemas)
|
(unless (ecss-schema-set-p schemas)
|
||||||
@ -102,6 +117,27 @@
|
|||||||
(cl-loop for key in options by #'cddr
|
(cl-loop for key in options by #'cddr
|
||||||
always (memq key ecss--schema-option-keys))))
|
always (memq key ecss--schema-option-keys))))
|
||||||
|
|
||||||
|
(defun ecss--plist-unique-keys-p (plist)
|
||||||
|
"Return non-nil when PLIST contains each key once."
|
||||||
|
(let (seen valid)
|
||||||
|
(setq valid t)
|
||||||
|
(while (and plist valid)
|
||||||
|
(let ((key (pop plist)))
|
||||||
|
(pop plist)
|
||||||
|
(setq valid (not (memq key seen)))
|
||||||
|
(push key seen)))
|
||||||
|
valid))
|
||||||
|
|
||||||
|
(defun ecss--unique-symbol-list-p (value &optional nonempty)
|
||||||
|
"Return non-nil when VALUE is a unique symbol list.
|
||||||
|
When NONEMPTY is non-nil, reject an empty list."
|
||||||
|
(and (proper-list-p value)
|
||||||
|
(or (not nonempty) value)
|
||||||
|
(cl-every (lambda (item)
|
||||||
|
(and (symbolp item) item))
|
||||||
|
value)
|
||||||
|
(= (length value) (length (delete-dups (copy-sequence value))))))
|
||||||
|
|
||||||
(defun ecss--schema-option (options key fallback)
|
(defun ecss--schema-option (options key fallback)
|
||||||
"Return KEY from OPTIONS when present, otherwise FALLBACK."
|
"Return KEY from OPTIONS when present, otherwise FALLBACK."
|
||||||
(if (plist-member options key) (plist-get options key) fallback))
|
(if (plist-member options key) (plist-get options key) fallback))
|
||||||
@ -122,66 +158,177 @@
|
|||||||
(list :invalid-initial initial)))
|
(list :invalid-initial initial)))
|
||||||
(ecss--copy-boundary-data normalized)))
|
(ecss--copy-boundary-data normalized)))
|
||||||
|
|
||||||
(defun ecss--build-property-schema (id options)
|
(defun ecss--build-property-schema (owner definition)
|
||||||
"Build a validated property schema for ID from OPTIONS."
|
"Build a validated property schema owned by OWNER from DEFINITION."
|
||||||
(unless (and (ecss--canonical-property-id-p id)
|
(let ((id (plist-get definition :id)))
|
||||||
(ecss--options-valid-p options))
|
(unless (and (ecss--canonical-property-id-p id)
|
||||||
(signal 'ecss-invalid-property-schema (list :property id options)))
|
(ecss--options-valid-p definition)
|
||||||
(ecss--validate-schema-functions options)
|
(ecss--plist-unique-keys-p definition)
|
||||||
(let* ((normalizer (ecss--schema-option options :normalizer #'identity))
|
(ecss--unique-symbol-list-p
|
||||||
(validator (ecss--schema-option
|
(or (plist-get definition :aliases) nil))
|
||||||
options :validator (lambda (_value) t)))
|
(ecss--unique-symbol-list-p
|
||||||
(initial (ecss--normalize-schema-initial
|
(plist-get definition :impacts) t)
|
||||||
(plist-get options :initial) normalizer validator)))
|
(ecss--unique-symbol-list-p
|
||||||
(ecss--make-property-schema
|
(or (plist-get definition :projections) nil)))
|
||||||
:id id :initial initial
|
(signal 'ecss-invalid-property-schema
|
||||||
:inherits (and (plist-get options :inherits) t)
|
(list :property id definition)))
|
||||||
:normalizer normalizer :validator validator
|
(ecss--validate-schema-functions definition)
|
||||||
:equality (ecss--schema-option options :equality #'equal)
|
(let* ((normalizer
|
||||||
:shorthand (plist-get options :shorthand))))
|
(ecss--schema-option definition :normalizer #'identity))
|
||||||
|
(validator
|
||||||
|
(ecss--schema-option
|
||||||
|
definition :validator (lambda (_value) t)))
|
||||||
|
(initial (ecss--normalize-schema-initial
|
||||||
|
(plist-get definition :initial) normalizer validator)))
|
||||||
|
(ecss--make-property-schema
|
||||||
|
:id id :owner owner :initial initial
|
||||||
|
:inherits (and (plist-get definition :inherits) t)
|
||||||
|
:normalizer normalizer :validator validator
|
||||||
|
:equality (ecss--schema-option definition :equality #'equal)
|
||||||
|
:shorthand (plist-get definition :shorthand)
|
||||||
|
:aliases (ecss--copy-boundary-data (plist-get definition :aliases))
|
||||||
|
:impacts (ecss--copy-boundary-data (plist-get definition :impacts))
|
||||||
|
:projections (ecss--copy-boundary-data
|
||||||
|
(plist-get definition :projections))
|
||||||
|
:metadata (ecss--copy-boundary-data
|
||||||
|
(plist-get definition :metadata))))))
|
||||||
|
|
||||||
|
(defun ecss--composition-collision (name kind existing-kind)
|
||||||
|
"Signal NAME collision between KIND and EXISTING-KIND."
|
||||||
|
(signal 'ecss-invalid-property-schema
|
||||||
|
(list :collision name kind existing-kind)))
|
||||||
|
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(defun ecss-schema-set-define (schemas id &rest options)
|
(defun ecss-schema-package-create (package-id definitions)
|
||||||
"Atomically define property ID with OPTIONS in SCHEMAS."
|
"Create immutable PACKAGE-ID schema registry from DEFINITIONS."
|
||||||
(ecss--schema-set-check schemas)
|
(unless (and (symbolp package-id) package-id (not (keywordp package-id)))
|
||||||
(let* ((schema (ecss--build-property-schema id options))
|
(signal 'ecss-invalid-property-schema
|
||||||
(table (ecss--schema-set-table schemas)))
|
(list :package-id package-id)))
|
||||||
(unless (gethash id table)
|
(unless (proper-list-p definitions)
|
||||||
(setf (ecss--schema-set-order schemas)
|
(signal 'ecss-invalid-property-schema
|
||||||
(append (ecss--schema-set-order schemas) (list id))))
|
(list :definitions definitions)))
|
||||||
(puthash id schema table)
|
(let ((table (make-hash-table :test #'eq))
|
||||||
(ecss--copy-property-schema schema)))
|
(aliases (make-hash-table :test #'eq))
|
||||||
|
order)
|
||||||
|
(dolist (definition definitions)
|
||||||
|
(unless (proper-list-p definition)
|
||||||
|
(signal 'ecss-invalid-property-schema
|
||||||
|
(list :definition definition)))
|
||||||
|
(let* ((schema (ecss--build-property-schema package-id definition))
|
||||||
|
(id (ecss-property-schema-id schema)))
|
||||||
|
(when (gethash id table)
|
||||||
|
(signal 'ecss-invalid-property-schema
|
||||||
|
(list :duplicate-property id)))
|
||||||
|
(when (gethash id aliases)
|
||||||
|
(ecss--composition-collision id 'canonical 'alias))
|
||||||
|
(puthash id schema table)
|
||||||
|
(push id order)
|
||||||
|
(dolist (alias (ecss-property-schema-aliases schema))
|
||||||
|
(when (gethash alias table)
|
||||||
|
(ecss--composition-collision alias 'alias 'canonical))
|
||||||
|
(when (gethash alias aliases)
|
||||||
|
(ecss--composition-collision alias 'alias 'alias))
|
||||||
|
(puthash alias id aliases))))
|
||||||
|
(ecss--make-schema-package
|
||||||
|
:id package-id :table table :order (nreverse order))))
|
||||||
|
|
||||||
|
(defun ecss-schema-package-id (package)
|
||||||
|
"Return immutable PACKAGE identity."
|
||||||
|
(unless (ecss-schema-package-p package)
|
||||||
|
(signal 'wrong-type-argument (list 'ecss-schema-package-p package)))
|
||||||
|
(ecss--schema-package-id package))
|
||||||
|
|
||||||
|
(defun ecss-schema-package-property-ids (package)
|
||||||
|
"Return canonical property identifiers owned by PACKAGE."
|
||||||
|
(unless (ecss-schema-package-p package)
|
||||||
|
(signal 'wrong-type-argument (list 'ecss-schema-package-p package)))
|
||||||
|
(copy-sequence (ecss--schema-package-order package)))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun ecss-schema-set-compose (&rest packages)
|
||||||
|
"Compose immutable PACKAGES into one atomic schema set."
|
||||||
|
(let ((package-ids nil)
|
||||||
|
(table (make-hash-table :test #'eq))
|
||||||
|
(aliases (make-hash-table :test #'eq))
|
||||||
|
order)
|
||||||
|
(dolist (package packages)
|
||||||
|
(unless (ecss-schema-package-p package)
|
||||||
|
(signal 'wrong-type-argument (list 'ecss-schema-package-p package)))
|
||||||
|
(let ((package-id (ecss--schema-package-id package)))
|
||||||
|
(when (memq package-id package-ids)
|
||||||
|
(signal 'ecss-invalid-property-schema
|
||||||
|
(list :duplicate-package package-id)))
|
||||||
|
(push package-id package-ids))
|
||||||
|
(dolist (id (ecss--schema-package-order package))
|
||||||
|
(when (gethash id table)
|
||||||
|
(ecss--composition-collision id 'canonical 'canonical))
|
||||||
|
(when (gethash id aliases)
|
||||||
|
(ecss--composition-collision id 'canonical 'alias))
|
||||||
|
(let ((schema (gethash id (ecss--schema-package-table package))))
|
||||||
|
(puthash id schema table)
|
||||||
|
(push id order)
|
||||||
|
(dolist (alias (ecss-property-schema-aliases schema))
|
||||||
|
(when (gethash alias table)
|
||||||
|
(ecss--composition-collision alias 'alias 'canonical))
|
||||||
|
(when (gethash alias aliases)
|
||||||
|
(ecss--composition-collision alias 'alias 'alias))
|
||||||
|
(puthash alias id aliases)))))
|
||||||
|
(ecss--make-schema-set
|
||||||
|
:package-ids (nreverse package-ids) :table table :aliases aliases
|
||||||
|
:order (nreverse order))))
|
||||||
|
|
||||||
(defun ecss--copy-property-schema (schema)
|
(defun ecss--copy-property-schema (schema)
|
||||||
"Return a defensive copy of SCHEMA."
|
"Return a defensive copy of SCHEMA."
|
||||||
(let ((copy (copy-ecss-property-schema schema)))
|
(let ((copy (copy-ecss-property-schema schema)))
|
||||||
(setf (ecss-property-schema-initial copy)
|
(setf (ecss-property-schema-initial copy)
|
||||||
(ecss--copy-boundary-data
|
(ecss--copy-boundary-data
|
||||||
(ecss-property-schema-initial schema)))
|
(ecss-property-schema-initial schema))
|
||||||
|
(ecss-property-schema-aliases copy)
|
||||||
|
(ecss--copy-boundary-data (ecss-property-schema-aliases schema))
|
||||||
|
(ecss-property-schema-impacts copy)
|
||||||
|
(ecss--copy-boundary-data (ecss-property-schema-impacts schema))
|
||||||
|
(ecss-property-schema-projections copy)
|
||||||
|
(ecss--copy-boundary-data (ecss-property-schema-projections schema))
|
||||||
|
(ecss-property-schema-metadata copy)
|
||||||
|
(ecss--copy-boundary-data (ecss-property-schema-metadata schema)))
|
||||||
copy))
|
copy))
|
||||||
|
|
||||||
(defun ecss-schema-set-property (schemas id)
|
(defun ecss-schema-set-package-ids (schemas)
|
||||||
"Return a defensive copy of property ID from SCHEMAS, or nil."
|
"Return package identities composed into SCHEMAS."
|
||||||
(ecss--schema-set-check schemas)
|
(ecss--schema-set-check schemas)
|
||||||
(when-let* ((schema (gethash id (ecss--schema-set-table schemas))))
|
(copy-sequence (ecss--schema-set-package-ids schemas)))
|
||||||
|
|
||||||
|
(defun ecss-schema-set-canonical-id (schemas name)
|
||||||
|
"Return canonical property identifier for NAME in SCHEMAS, or nil."
|
||||||
|
(ecss--schema-set-check schemas)
|
||||||
|
(cond ((gethash name (ecss--schema-set-table schemas)) name)
|
||||||
|
((gethash name (ecss--schema-set-aliases schemas)))))
|
||||||
|
|
||||||
|
(defun ecss-schema-set-property (schemas id)
|
||||||
|
"Return a defensive property schema copy for ID or alias in SCHEMAS."
|
||||||
|
(ecss--schema-set-check schemas)
|
||||||
|
(when-let* ((canonical (ecss-schema-set-canonical-id schemas id))
|
||||||
|
(schema (gethash canonical (ecss--schema-set-table schemas))))
|
||||||
(ecss--copy-property-schema schema)))
|
(ecss--copy-property-schema schema)))
|
||||||
|
|
||||||
(defun ecss-schema-set-property-ids (schemas)
|
(defun ecss-schema-set-property-ids (schemas)
|
||||||
"Return property identifiers from SCHEMAS in registration order."
|
"Return property identifiers from SCHEMAS in registration order."
|
||||||
(ecss--schema-set-check schemas)
|
(ecss--schema-set-check schemas)
|
||||||
(ecss--copy-boundary-data (ecss--schema-set-order schemas)))
|
(copy-sequence (ecss--schema-set-order schemas)))
|
||||||
|
|
||||||
(defun ecss-schema-set-clear (schemas)
|
(defun ecss-schema-set-property-metadata (schemas id)
|
||||||
"Remove every property schema from SCHEMAS."
|
"Return detached property metadata for ID in SCHEMAS."
|
||||||
(ecss--schema-set-check schemas)
|
(ecss--schema-set-check schemas)
|
||||||
(clrhash (ecss--schema-set-table schemas))
|
(when-let* ((canonical (ecss-schema-set-canonical-id schemas id))
|
||||||
(setf (ecss--schema-set-order schemas) nil)
|
(schema (gethash canonical (ecss--schema-set-table schemas))))
|
||||||
schemas)
|
(ecss--copy-boundary-data (ecss-property-schema-metadata schema))))
|
||||||
|
|
||||||
(defun ecss-property-equal-p (schemas property left right)
|
(defun ecss-property-equal-p (schemas property left right)
|
||||||
"Return whether PROPERTY values LEFT and RIGHT are equal in SCHEMAS."
|
"Return whether PROPERTY values LEFT and RIGHT are equal in SCHEMAS."
|
||||||
(ecss--schema-set-check schemas)
|
(ecss--schema-set-check schemas)
|
||||||
(let ((schema (gethash property (ecss--schema-set-table schemas))))
|
(let* ((canonical (ecss-schema-set-canonical-id schemas property))
|
||||||
|
(schema (and canonical
|
||||||
|
(gethash canonical (ecss--schema-set-table schemas)))))
|
||||||
(unless schema
|
(unless schema
|
||||||
(signal 'ecss-invalid-declaration (list :unknown-property property)))
|
(signal 'ecss-invalid-declaration (list :unknown-property property)))
|
||||||
(funcall (ecss-property-schema-equality schema) left right)))
|
(funcall (ecss-property-schema-equality schema) left right)))
|
||||||
@ -215,7 +362,8 @@
|
|||||||
|
|
||||||
(defun ecss--schema-for (schemas property)
|
(defun ecss--schema-for (schemas property)
|
||||||
"Return PROPERTY schema from SCHEMAS, or nil."
|
"Return PROPERTY schema from SCHEMAS, or nil."
|
||||||
(gethash property (ecss--schema-set-table schemas)))
|
(when-let* ((canonical (ecss-schema-set-canonical-id schemas property)))
|
||||||
|
(gethash canonical (ecss--schema-set-table schemas))))
|
||||||
|
|
||||||
(defun ecss--validate-declaration-property (schemas property)
|
(defun ecss--validate-declaration-property (schemas property)
|
||||||
"Return PROPERTY when it is valid for SCHEMAS."
|
"Return PROPERTY when it is valid for SCHEMAS."
|
||||||
@ -253,7 +401,9 @@
|
|||||||
(defun ecss--expand-declaration (schemas property value)
|
(defun ecss--expand-declaration (schemas property value)
|
||||||
"Expand one PROPERTY VALUE declaration using SCHEMAS."
|
"Expand one PROPERTY VALUE declaration using SCHEMAS."
|
||||||
(ecss--validate-declaration-property schemas property)
|
(ecss--validate-declaration-property schemas property)
|
||||||
(let ((schema (ecss--schema-for schemas property)))
|
(let* ((canonical (or (ecss-schema-set-canonical-id schemas property)
|
||||||
|
property))
|
||||||
|
(schema (ecss--schema-for schemas canonical)))
|
||||||
(if-let* ((expander (and schema
|
(if-let* ((expander (and schema
|
||||||
(ecss-property-schema-shorthand schema))))
|
(ecss-property-schema-shorthand schema))))
|
||||||
(pcase-let* ((`(,raw . ,important) (ecss--unwrap-important value))
|
(pcase-let* ((`(,raw . ,important) (ecss--unwrap-important value))
|
||||||
@ -261,9 +411,15 @@
|
|||||||
(ecss--copy-boundary-data
|
(ecss--copy-boundary-data
|
||||||
(funcall expander
|
(funcall expander
|
||||||
(ecss--copy-boundary-data raw)))))
|
(ecss--copy-boundary-data raw)))))
|
||||||
(ecss--validate-expanded-longhands schemas property expanded)
|
(ecss--validate-expanded-longhands schemas canonical expanded)
|
||||||
(ecss--tag-important expanded important))
|
(ecss--tag-important
|
||||||
(list property (ecss--copy-boundary-data value)))))
|
(cl-loop for (longhand longhand-value) on expanded by #'cddr
|
||||||
|
append
|
||||||
|
(list (or (ecss-schema-set-canonical-id schemas longhand)
|
||||||
|
longhand)
|
||||||
|
longhand-value))
|
||||||
|
important))
|
||||||
|
(list canonical (ecss--copy-boundary-data value)))))
|
||||||
|
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(defun ecss-expand-declarations (schemas declarations)
|
(defun ecss-expand-declarations (schemas declarations)
|
||||||
@ -271,8 +427,25 @@
|
|||||||
(ecss--schema-set-check schemas)
|
(ecss--schema-set-check schemas)
|
||||||
(unless (ecss--declaration-list-p declarations)
|
(unless (ecss--declaration-list-p declarations)
|
||||||
(signal 'ecss-invalid-declaration (list :declarations declarations)))
|
(signal 'ecss-invalid-declaration (list :declarations declarations)))
|
||||||
(cl-loop for (property value) on declarations by #'cddr
|
(let ((seen (make-hash-table :test #'eq)) result)
|
||||||
append (ecss--expand-declaration schemas property value)))
|
(cl-loop
|
||||||
|
for (source-property source-value) on declarations by #'cddr
|
||||||
|
for expanded = (ecss--expand-declaration
|
||||||
|
schemas source-property source-value)
|
||||||
|
do
|
||||||
|
(cl-loop
|
||||||
|
for (property value) on expanded by #'cddr
|
||||||
|
for previous = (gethash property seen)
|
||||||
|
do
|
||||||
|
(when previous
|
||||||
|
(signal 'ecss-invalid-declaration
|
||||||
|
(list :duplicate-property property
|
||||||
|
:first-source previous
|
||||||
|
:second-source source-property)))
|
||||||
|
(puthash property source-property seen)
|
||||||
|
(push property result)
|
||||||
|
(push value result)))
|
||||||
|
(nreverse result)))
|
||||||
|
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(defun ecss-merge-declarations (schemas &rest declaration-groups)
|
(defun ecss-merge-declarations (schemas &rest declaration-groups)
|
||||||
@ -890,7 +1063,7 @@ handle explicit sources. DIAGNOSTICS records failures; PROVENANCE-P retains
|
|||||||
facts."
|
facts."
|
||||||
(let (values active specified provenance)
|
(let (values active specified provenance)
|
||||||
(dolist (property (ecss--schema-set-order schemas))
|
(dolist (property (ecss--schema-set-order schemas))
|
||||||
(let ((schema (ecss--schema-for schemas property)))
|
(let ((schema (gethash property (ecss--schema-set-table schemas))))
|
||||||
(unless (ecss-property-schema-shorthand schema)
|
(unless (ecss-property-schema-shorthand schema)
|
||||||
(pcase-let ((`(,value ,winner ,invalid ,source)
|
(pcase-let ((`(,value ,winner ,invalid ,source)
|
||||||
(ecss--resolve-property-candidates
|
(ecss--resolve-property-candidates
|
||||||
@ -975,7 +1148,8 @@ non-nil, is the only function allowed to evaluate caller-owned value sources;
|
|||||||
schemas table parent-style custom-tables subject value-resolver
|
schemas table parent-style custom-tables subject value-resolver
|
||||||
diagnostics provenance)))
|
diagnostics provenance)))
|
||||||
(ecss--make-computed-style
|
(ecss--make-computed-style
|
||||||
:values values :custom-properties custom :active-properties active
|
:schemas schemas :values values :custom-properties custom
|
||||||
|
:active-properties active
|
||||||
:specified-properties specified
|
:specified-properties specified
|
||||||
:provenance (and provenance
|
:provenance (and provenance
|
||||||
(append (cadr raw-facts) property-facts))
|
(append (cadr raw-facts) property-facts))
|
||||||
@ -1045,21 +1219,53 @@ the public boundary."
|
|||||||
|
|
||||||
(defun ecss-computed-style-value (style property &optional fallback)
|
(defun ecss-computed-style-value (style property &optional fallback)
|
||||||
"Return PROPERTY from computed STYLE, or FALLBACK when absent."
|
"Return PROPERTY from computed STYLE, or FALLBACK when absent."
|
||||||
(let ((values (ecss--computed-style-values
|
(setq style (ecss--computed-style-check style))
|
||||||
(ecss--computed-style-check style))))
|
(let* ((schemas (ecss--computed-style-schemas style))
|
||||||
(if (plist-member values property) (plist-get values property) fallback)))
|
(canonical (or (ecss-schema-set-canonical-id schemas property)
|
||||||
|
property))
|
||||||
|
(values (ecss--computed-style-values style)))
|
||||||
|
(if (plist-member values canonical)
|
||||||
|
(ecss--copy-boundary-data (plist-get values canonical))
|
||||||
|
fallback)))
|
||||||
|
|
||||||
|
(defun ecss-computed-style-property-fact (style property)
|
||||||
|
"Return one immutable computed fact for PROPERTY in STYLE, or nil."
|
||||||
|
(setq style (ecss--computed-style-check style))
|
||||||
|
(let* ((schemas (ecss--computed-style-schemas style))
|
||||||
|
(canonical (ecss-schema-set-canonical-id schemas property))
|
||||||
|
(schema (and canonical
|
||||||
|
(gethash canonical (ecss--schema-set-table schemas))))
|
||||||
|
(values (ecss--computed-style-values style)))
|
||||||
|
(when (and schema (plist-member values canonical))
|
||||||
|
(ecss--make-computed-property-fact
|
||||||
|
:property canonical
|
||||||
|
:value (ecss--copy-boundary-data (plist-get values canonical))
|
||||||
|
:owner (ecss-property-schema-owner schema)
|
||||||
|
:impacts (ecss--copy-boundary-data
|
||||||
|
(ecss-property-schema-impacts schema))
|
||||||
|
:projections (ecss--copy-boundary-data
|
||||||
|
(ecss-property-schema-projections schema))
|
||||||
|
:provenance
|
||||||
|
(ecss--copy-boundary-data
|
||||||
|
(plist-get (ecss--computed-style-provenance style) canonical))
|
||||||
|
:metadata (ecss--copy-boundary-data
|
||||||
|
(ecss-property-schema-metadata schema))))))
|
||||||
|
|
||||||
(defun ecss-computed-style-present-p (style property)
|
(defun ecss-computed-style-present-p (style property)
|
||||||
"Return non-nil when PROPERTY is actively supplied in computed STYLE."
|
"Return non-nil when PROPERTY is actively supplied in computed STYLE."
|
||||||
(memq property
|
(setq style (ecss--computed-style-check style))
|
||||||
(ecss--computed-style-active-properties
|
(memq (or (ecss-schema-set-canonical-id
|
||||||
(ecss--computed-style-check style))))
|
(ecss--computed-style-schemas style) property)
|
||||||
|
property)
|
||||||
|
(ecss--computed-style-active-properties style)))
|
||||||
|
|
||||||
(defun ecss-computed-style-specified-p (style property)
|
(defun ecss-computed-style-specified-p (style property)
|
||||||
"Return non-nil when PROPERTY has a cascade winner in computed STYLE."
|
"Return non-nil when PROPERTY has a cascade winner in computed STYLE."
|
||||||
(memq property
|
(setq style (ecss--computed-style-check style))
|
||||||
(ecss--computed-style-specified-properties
|
(memq (or (ecss-schema-set-canonical-id
|
||||||
(ecss--computed-style-check style))))
|
(ecss--computed-style-schemas style) property)
|
||||||
|
property)
|
||||||
|
(ecss--computed-style-specified-properties style)))
|
||||||
|
|
||||||
(provide 'ecss-cascade)
|
(provide 'ecss-cascade)
|
||||||
;;; ecss-cascade.el ends here
|
;;; ecss-cascade.el ends here
|
||||||
|
|||||||
@ -49,6 +49,16 @@
|
|||||||
Function values retain identity so executable literals remain callable."
|
Function values retain identity so executable literals remain callable."
|
||||||
(cond
|
(cond
|
||||||
((functionp value) value)
|
((functionp value) value)
|
||||||
|
((hash-table-p value)
|
||||||
|
(let ((copy (copy-hash-table value)))
|
||||||
|
(clrhash copy)
|
||||||
|
(maphash
|
||||||
|
(lambda (key item)
|
||||||
|
(puthash (ecss--copy-boundary-data key)
|
||||||
|
(ecss--copy-boundary-data item)
|
||||||
|
copy))
|
||||||
|
value)
|
||||||
|
copy))
|
||||||
((consp value)
|
((consp value)
|
||||||
(cons (ecss--copy-boundary-data (car value))
|
(cons (ecss--copy-boundary-data (car value))
|
||||||
(ecss--copy-boundary-data (cdr value))))
|
(ecss--copy-boundary-data (cdr value))))
|
||||||
|
|||||||
@ -11,24 +11,28 @@
|
|||||||
|
|
||||||
(defun ecss-cascade-test--schemas ()
|
(defun ecss-cascade-test--schemas ()
|
||||||
"Return the standard test schema set."
|
"Return the standard test schema set."
|
||||||
(let ((schemas (ecss-schema-set-create)))
|
(ecss-schema-set-compose
|
||||||
(ecss-schema-set-define
|
(ecss-schema-package-create
|
||||||
schemas 'app/color :initial "black" :inherits t
|
'app
|
||||||
:validator #'stringp)
|
(append
|
||||||
(ecss-schema-set-define
|
(list
|
||||||
schemas 'app/width :initial 0 :validator #'integerp)
|
(list :id 'app/color :initial "black" :inherits t
|
||||||
(ecss-schema-set-define schemas 'app/payload :initial nil :inherits t)
|
:validator #'stringp :impacts '(paint))
|
||||||
(dolist (property '(app/padding-top app/padding-right
|
(list :id 'app/width :initial 0 :validator #'integerp
|
||||||
app/padding-bottom app/padding-left))
|
:impacts '(geometry))
|
||||||
(ecss-schema-set-define
|
(list :id 'app/payload :initial nil :inherits t :impacts '(data)))
|
||||||
schemas property :initial 0 :validator #'integerp))
|
(mapcar (lambda (property)
|
||||||
(ecss-schema-set-define
|
(list :id property :initial 0 :validator #'integerp
|
||||||
schemas 'app/padding
|
:impacts '(geometry)))
|
||||||
:shorthand
|
'(app/padding-top app/padding-right
|
||||||
(lambda (value)
|
app/padding-bottom app/padding-left))
|
||||||
(list 'app/padding-top value 'app/padding-right value
|
(list
|
||||||
'app/padding-bottom value 'app/padding-left value)))
|
(list
|
||||||
schemas))
|
:id 'app/padding :initial nil :impacts '(geometry)
|
||||||
|
:shorthand
|
||||||
|
(lambda (value)
|
||||||
|
(list 'app/padding-top value 'app/padding-right value
|
||||||
|
'app/padding-bottom value 'app/padding-left value))))))))
|
||||||
|
|
||||||
(defun ecss-cascade-test--subject (&rest options)
|
(defun ecss-cascade-test--subject (&rest options)
|
||||||
"Return a button subject using OPTIONS."
|
"Return a button subject using OPTIONS."
|
||||||
@ -59,30 +63,36 @@
|
|||||||
(should (equal "blue"
|
(should (equal "blue"
|
||||||
(ecss-computed-style-value copy 'app/color)))))
|
(ecss-computed-style-value copy 'app/color)))))
|
||||||
|
|
||||||
(ert-deftest ecss-cascade-test-schema-registration-is-atomic ()
|
(ert-deftest ecss-cascade-test-schema-construction-is-atomic ()
|
||||||
(let ((schemas (ecss-schema-set-create)))
|
(should-error
|
||||||
(ecss-schema-set-define schemas 'app/width :initial 4 :validator #'integerp)
|
(ecss-schema-package-create
|
||||||
(should-error
|
'app
|
||||||
(ecss-schema-set-define schemas 'app/width :initial "bad"
|
'((:id app/width :initial 4 :validator integerp :impacts (geometry))
|
||||||
:validator #'integerp)
|
(:id app/bad :initial "bad" :validator integerp :impacts (geometry))))
|
||||||
:type 'ecss-invalid-property-schema)
|
:type 'ecss-invalid-property-schema)
|
||||||
|
(let ((schemas
|
||||||
|
(ecss-schema-set-compose
|
||||||
|
(ecss-schema-package-create
|
||||||
|
'app
|
||||||
|
'((:id app/width :initial 4 :validator integerp
|
||||||
|
:impacts (geometry)))))))
|
||||||
(should (= (ecss-property-schema-initial
|
(should (= (ecss-property-schema-initial
|
||||||
(ecss-schema-set-property schemas 'app/width))
|
(ecss-schema-set-property schemas 'app/width))
|
||||||
4))
|
4))))
|
||||||
(should-error
|
|
||||||
(ecss-schema-set-define schemas 'not-namespaced :initial 1)
|
|
||||||
:type 'ecss-invalid-property-schema)
|
|
||||||
(should (equal (ecss-schema-set-property-ids schemas) '(app/width)))))
|
|
||||||
|
|
||||||
(ert-deftest ecss-cascade-test-computed-defaults-are-not-renormalized ()
|
(ert-deftest ecss-cascade-test-computed-defaults-are-not-renormalized ()
|
||||||
(let ((schemas (ecss-schema-set-create))
|
(let ((subject (ecss-cascade-test--subject))
|
||||||
(subject (ecss-cascade-test--subject))
|
|
||||||
(normalizations 0))
|
(normalizations 0))
|
||||||
(ecss-schema-set-define
|
(let* ((schemas
|
||||||
schemas 'app/value :initial 2 :inherits t
|
(ecss-schema-set-compose
|
||||||
:normalizer (lambda (value) (cl-incf normalizations) (* value 10))
|
(ecss-schema-package-create
|
||||||
:validator #'integerp)
|
'app
|
||||||
(let* ((initial (ecss-compute-style schemas subject))
|
(list
|
||||||
|
(list :id 'app/value :initial 2 :inherits t
|
||||||
|
:normalizer
|
||||||
|
(lambda (value) (cl-incf normalizations) (* value 10))
|
||||||
|
:validator #'integerp :impacts '(data))))))
|
||||||
|
(initial (ecss-compute-style schemas subject))
|
||||||
(declared (ecss-compute-style
|
(declared (ecss-compute-style
|
||||||
schemas subject :declarations '(app/value 3)))
|
schemas subject :declarations '(app/value 3)))
|
||||||
(inherited (ecss-compute-style
|
(inherited (ecss-compute-style
|
||||||
@ -136,21 +146,15 @@
|
|||||||
(should (eq (aref merged-value 1) literal))
|
(should (eq (aref merged-value 1) literal))
|
||||||
(should (eq (funcall (aref merged-value 1)) :literal))))
|
(should (eq (funcall (aref merged-value 1)) :literal))))
|
||||||
|
|
||||||
(ert-deftest ecss-cascade-test-shorthand-and-longhand-follow-declaration-order ()
|
(ert-deftest ecss-cascade-test-shorthand-and-longhand-conflict-in-one-source ()
|
||||||
(let ((schemas (ecss-cascade-test--schemas))
|
(let ((schemas (ecss-cascade-test--schemas))
|
||||||
(subject (ecss-cascade-test--subject)))
|
(subject (ecss-cascade-test--subject)))
|
||||||
(should (= (ecss-cascade-test--value
|
(dolist (declarations
|
||||||
(ecss-compute-style
|
'((app/padding 1 app/padding-left 2)
|
||||||
schemas subject
|
(app/padding-left 2 app/padding 1)))
|
||||||
:declarations '(app/padding 1 app/padding-left 2))
|
(should-error
|
||||||
'app/padding-left)
|
(ecss-compute-style schemas subject :declarations declarations)
|
||||||
2))
|
:type 'ecss-invalid-declaration))))
|
||||||
(should (= (ecss-cascade-test--value
|
|
||||||
(ecss-compute-style
|
|
||||||
schemas subject
|
|
||||||
:declarations '(app/padding-left 2 app/padding 1))
|
|
||||||
'app/padding-left)
|
|
||||||
1))))
|
|
||||||
|
|
||||||
(ert-deftest ecss-cascade-test-rule-addition-is-atomic ()
|
(ert-deftest ecss-cascade-test-rule-addition-is-atomic ()
|
||||||
(let ((schemas (ecss-cascade-test--schemas))
|
(let ((schemas (ecss-cascade-test--schemas))
|
||||||
@ -626,9 +630,13 @@
|
|||||||
'((theme base)))))))
|
'((theme base)))))))
|
||||||
|
|
||||||
(ert-deftest ecss-cascade-test-schema-boundaries-copy-mutable-values ()
|
(ert-deftest ecss-cascade-test-schema-boundaries-copy-mutable-values ()
|
||||||
(let* ((schemas (ecss-schema-set-create))
|
(let* ((caller-initial (vector (copy-sequence "base")))
|
||||||
(caller-initial (vector (copy-sequence "base"))))
|
(schemas
|
||||||
(ecss-schema-set-define schemas 'app/value :initial caller-initial)
|
(ecss-schema-set-compose
|
||||||
|
(ecss-schema-package-create
|
||||||
|
'app
|
||||||
|
(list (list :id 'app/value :initial caller-initial
|
||||||
|
:impacts '(data)))))))
|
||||||
(aset (aref caller-initial 0) 0 ?X)
|
(aset (aref caller-initial 0) 0 ?X)
|
||||||
(let ((stored (ecss-property-schema-initial
|
(let ((stored (ecss-property-schema-initial
|
||||||
(ecss-schema-set-property schemas 'app/value))))
|
(ecss-schema-set-property schemas 'app/value))))
|
||||||
|
|||||||
@ -49,12 +49,16 @@
|
|||||||
"0.1.0")))))
|
"0.1.0")))))
|
||||||
|
|
||||||
(ert-deftest ecss-package-test-independent-schema-and-stylesheet-state ()
|
(ert-deftest ecss-package-test-independent-schema-and-stylesheet-state ()
|
||||||
(let ((left-schemas (ecss-schema-set-create))
|
(let ((left-schemas
|
||||||
(right-schemas (ecss-schema-set-create))
|
(ecss-schema-set-compose
|
||||||
|
(ecss-schema-package-create
|
||||||
|
'left '((:id left/color :initial "left" :impacts (paint))))))
|
||||||
|
(right-schemas
|
||||||
|
(ecss-schema-set-compose
|
||||||
|
(ecss-schema-package-create
|
||||||
|
'right '((:id right/color :initial "right" :impacts (paint))))))
|
||||||
(left-sheet (ecss-stylesheet-create))
|
(left-sheet (ecss-stylesheet-create))
|
||||||
(right-sheet (ecss-stylesheet-create)))
|
(right-sheet (ecss-stylesheet-create)))
|
||||||
(ecss-schema-set-define left-schemas 'left/color :initial "left")
|
|
||||||
(ecss-schema-set-define right-schemas 'right/color :initial "right")
|
|
||||||
(ecss-stylesheet-add-rule
|
(ecss-stylesheet-add-rule
|
||||||
left-sheet left-schemas "*" '(left/color "changed"))
|
left-sheet left-schemas "*" '(left/color "changed"))
|
||||||
(should (null (ecss-stylesheet-rules right-sheet)))
|
(should (null (ecss-stylesheet-rules right-sheet)))
|
||||||
|
|||||||
271
tests/ecss-schema-tests.el
Normal file
271
tests/ecss-schema-tests.el
Normal file
@ -0,0 +1,271 @@
|
|||||||
|
;;; 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
|
||||||
Loading…
Reference in New Issue
Block a user