240 lines
9.7 KiB
EmacsLisp
240 lines
9.7 KiB
EmacsLisp
;;; ebox-fixtures.el --- Typed Ebox test fixtures -*- lexical-binding: t; -*-
|
|
|
|
;;; Commentary:
|
|
;; Test-only construction helpers. They keep retained layout, publication,
|
|
;; and rollback tests on the canonical Text/Box/LayoutConfig model without
|
|
;; reintroducing removed public constructors.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'ebox)
|
|
|
|
(defconst ebox-test--source-fields
|
|
'(:source-identity :key :class :id
|
|
:selector-state :selector-attributes)
|
|
"Author source fields owned by opaque fixture source handles.")
|
|
|
|
(defconst ebox-test--direct-fields
|
|
'(:region-id :surface-properties :scroll-offset
|
|
:ebox-scroll-offset-controlled-p)
|
|
"Private runtime fields used only by focused backend tests.")
|
|
|
|
(defconst ebox-test--non-style-fields
|
|
(append ebox-test--source-fields
|
|
'(:outer :item-gap :cross-align)
|
|
ebox-test--direct-fields)
|
|
"Fixture fields that do not enter the canonical Ebox style schema.")
|
|
|
|
(defun ebox-test-root (input)
|
|
"Return the single canonical root owned by fixture INPUT."
|
|
(ebox-canonical-input--single-root input "Ebox test fixture"))
|
|
|
|
(defun ebox-test-forest (input)
|
|
"Return fixture INPUT's ordered canonical forest."
|
|
(unless (ebox-canonical-input-p input)
|
|
(signal 'wrong-type-argument (list 'ebox-canonical-input-p input)))
|
|
(copy-sequence (ebox-canonical-input--nodes input)))
|
|
|
|
(defun ebox-test-source-index (input)
|
|
"Return the immutable source generation owned by fixture INPUT."
|
|
(unless (ebox-canonical-input-p input)
|
|
(signal 'wrong-type-argument (list 'ebox-canonical-input-p input)))
|
|
(ebox-canonical-input--source-index input))
|
|
|
|
(defun ebox-test-child-range (range-ref &rest inputs)
|
|
"Return a test Range descriptor over canonical INPUTS.
|
|
The descriptor is consumed only by a fixture parent, which imports every input
|
|
source generation before lowering the descriptor to raw canonical nodes."
|
|
(unless range-ref
|
|
(error "Ebox test Range ref must be non-nil"))
|
|
(dolist (input inputs)
|
|
(unless (ebox-canonical-input-p input)
|
|
(signal 'wrong-type-argument (list 'ebox-canonical-input-p input))))
|
|
(ebox-child-range--descriptor-create range-ref inputs))
|
|
|
|
(defun ebox-test-forest-input (&rest inputs)
|
|
"Combine canonical INPUTS into one ordered forest input."
|
|
(let ((builder (ebox-source-builder-create))
|
|
nodes)
|
|
(dolist (input inputs)
|
|
(unless (ebox-canonical-input-p input)
|
|
(signal 'wrong-type-argument (list 'ebox-canonical-input-p input)))
|
|
(ebox-source-builder-import builder (ebox-test-source-index input))
|
|
(setq nodes (nconc nodes (ebox-test-forest input))))
|
|
(ebox-canonical-input-create nodes (ebox-source-builder-finish builder))))
|
|
|
|
(defun ebox-test--keep (plist keys)
|
|
"Return PLIST entries whose keys occur in KEYS."
|
|
(cl-loop for (key value) on plist by #'cddr
|
|
when (memq key keys) append (list key value)))
|
|
|
|
(defun ebox-test--split-items (items)
|
|
"Return `(PROPERTIES . CHILDREN)' from evaluated fixture ITEMS."
|
|
(let (properties children)
|
|
(while items
|
|
(let ((item (pop items)))
|
|
(if (keywordp item)
|
|
(progn
|
|
(unless items (error "Missing fixture value for %S" item))
|
|
(setq properties
|
|
(append properties (list item (pop items)))))
|
|
(push item children))))
|
|
(cons properties (nreverse children))))
|
|
|
|
(defun ebox-test--without (plist keys)
|
|
"Return PLIST without entries whose keys occur in KEYS."
|
|
(cl-loop for (key value) on plist by #'cddr
|
|
unless (memq key keys) append (list key value)))
|
|
|
|
(defun ebox-test--source-handle (builder props declarations)
|
|
"Return one opaque fixture source for PROPS and DECLARATIONS.
|
|
The optional `:source-identity' fixture property explicitly names its stable
|
|
author identity; opaque source handles remain internal to SourceBuilder."
|
|
(let* ((identity (plist-get props :source-identity))
|
|
(arguments
|
|
(list :key (plist-get props :key)
|
|
:id (plist-get props :id)
|
|
:class (plist-get props :class)
|
|
:selector-state (plist-get props :selector-state)
|
|
:selector-attributes (plist-get props :selector-attributes)
|
|
:declarations declarations
|
|
:provenance '(:adapter ebox-test))))
|
|
(apply #'ebox-source-builder-bind
|
|
builder
|
|
(append
|
|
(and identity (list :identity identity))
|
|
arguments))))
|
|
|
|
(defun ebox-test--declarations (tag props)
|
|
"Return canonical TAG declarations from evaluated fixture PROPS."
|
|
(ebox-style-compile-form
|
|
tag (ebox-test--without props ebox-test--non-style-fields)))
|
|
|
|
(defun ebox-test--layout (tag props declarations)
|
|
"Return TAG LayoutConfig from PROPS and DECLARATIONS."
|
|
(ebox-layout-config-for-form
|
|
tag
|
|
(if (memq tag '(row column))
|
|
(ebox-test--keep props '(:item-gap :cross-align))
|
|
(ebox-style-declaration-properties
|
|
declarations
|
|
(lambda (property)
|
|
(memq (plist-get property :name)
|
|
(ebox-layout-config-property-names tag)))))))
|
|
|
|
(defun ebox-test-text (value &rest props)
|
|
"Return one canonical Text input for VALUE and author PROPS."
|
|
(let* ((builder (ebox-source-builder-create))
|
|
(declarations (ebox-test--declarations 'text props))
|
|
(node
|
|
(ebox-text-create
|
|
:value value
|
|
:owned-facts
|
|
(ebox-canonical-facts-from-declarations 'text declarations)
|
|
:source-handle
|
|
(ebox-test--source-handle builder props declarations)))
|
|
(index (ebox-source-builder-finish builder)))
|
|
(ebox-canonical-input-create (list node) index)))
|
|
|
|
(defun ebox-test--normalize-child (builder child)
|
|
"Import fixture CHILD into BUILDER and return its canonical node value."
|
|
(cond
|
|
((ebox-canonical-input-p child)
|
|
(ebox-source-builder-import builder (ebox-test-source-index child))
|
|
(ebox-test-root child))
|
|
((ebox-child-range--descriptor-p child)
|
|
(ebox-child-range--descriptor-create
|
|
(ebox-child-range--descriptor-ref child)
|
|
(mapcar (lambda (item)
|
|
(ebox-test--normalize-child builder item))
|
|
(ebox-child-range--descriptor-items child))))
|
|
(t
|
|
(error "Fixture child must be a canonical input or Range: %S" child))))
|
|
|
|
(defun ebox-test--box-node (tag props children)
|
|
"Return canonical Box input TAG from PROPS and CHILDREN."
|
|
(let* ((builder (ebox-source-builder-create))
|
|
(declarations (ebox-test--declarations tag props))
|
|
(nodes (mapcar (lambda (child)
|
|
(ebox-test--normalize-child builder child))
|
|
children))
|
|
(node
|
|
(let ((ebox-canonical--source-builder builder))
|
|
(ebox-box-create
|
|
:layout (ebox-test--layout tag props declarations)
|
|
:outer (or (plist-get props :outer) 'block)
|
|
:children nodes
|
|
:owned-facts
|
|
(ebox-canonical-facts-from-declarations tag declarations)
|
|
:source-handle
|
|
(ebox-test--source-handle builder props declarations))))
|
|
(index (ebox-source-builder-finish builder)))
|
|
(dolist (key ebox-test--direct-fields)
|
|
(when (plist-member props key)
|
|
(plist-put node key (copy-tree (plist-get props key)))))
|
|
(ebox-canonical-input-create (list node) index)))
|
|
|
|
(defun ebox-test-box (&rest items)
|
|
"Return one typed Normal Box fixture from evaluated ITEMS."
|
|
(pcase-let ((`(,props . ,children) (ebox-test--split-items items)))
|
|
(ebox-test--box-node 'box props children)))
|
|
|
|
(defun ebox-test-row (&rest items)
|
|
"Return one typed Row fixture from evaluated ITEMS."
|
|
(pcase-let ((`(,props . ,children) (ebox-test--split-items items)))
|
|
(ebox-test--box-node 'row props (delq nil children))))
|
|
|
|
(defun ebox-test-column (&rest items)
|
|
"Return one typed Column fixture from evaluated ITEMS."
|
|
(pcase-let ((`(,props . ,children) (ebox-test--split-items items)))
|
|
(ebox-test--box-node 'column props (delq nil children))))
|
|
|
|
(defun ebox-test-flex (&rest items)
|
|
"Return one typed Flex fixture from evaluated ITEMS."
|
|
(pcase-let ((`(,props . ,children) (ebox-test--split-items items)))
|
|
(ebox-test--box-node 'flex props (delq nil children))))
|
|
|
|
(defun ebox-test-grid (&rest items)
|
|
"Return one typed Grid fixture from evaluated ITEMS."
|
|
(pcase-let ((`(,props . ,children) (ebox-test--split-items items)))
|
|
(ebox-test--box-node 'grid props (delq nil children))))
|
|
|
|
(defun ebox-test-grid-fr (factor)
|
|
"Return one fractional Grid track fixture."
|
|
(list 'fr factor))
|
|
|
|
(defun ebox-test-flex-item (node &rest props)
|
|
"Return INPUT with direct Flex participation and Box properties from PROPS."
|
|
(unless (ebox-canonical-input-p node)
|
|
(signal 'wrong-type-argument (list 'ebox-canonical-input-p node)))
|
|
(unless (ebox-box-node-p (ebox-test-root node))
|
|
(setq node (ebox-test--box-node 'box nil (list node))))
|
|
(let* ((source-index (ebox-test-source-index node))
|
|
(node (ebox-test-root node))
|
|
(source (or (ebox-node-source-handle node)
|
|
(error "Fixture Box lacks an opaque source handle: %S"
|
|
node)))
|
|
(layout (ebox-box-node-layout node))
|
|
(children (ebox-box-node-children node))
|
|
(base (ebox-style-node-declarations source-index node))
|
|
(extra (ebox-test--declarations 'box props))
|
|
(declarations (ebox-style-merge-declarations base extra))
|
|
(binding
|
|
(ebox-source-index-rebind
|
|
source-index source :declarations declarations))
|
|
(copy
|
|
(ebox-box-create
|
|
:layout layout
|
|
:children children
|
|
:outer (ebox-tree-display-outer node)
|
|
:owned-facts
|
|
(ebox-canonical-facts-from-declarations
|
|
'box declarations)
|
|
:source-handle (cdr binding))))
|
|
(ebox-canonical-input-create (list copy) (car binding))))
|
|
|
|
(provide 'ebox-fixtures)
|
|
|
|
;;; ebox-fixtures.el ends here
|