test: keep M0 evidence package-local
This commit is contained in:
Kinneyzhang
parent
d124c33ba4
commit
3ed2d39f4c
3
Makefile
3
Makefile
@ -32,6 +32,7 @@ compile:
|
||||
--eval '(dolist (file (quote ($(foreach file,$(EXAMPLES),"$(file)")))) (byte-compile-file file))' \
|
||||
--eval '(byte-compile-file "etaf-playground.el")' \
|
||||
--eval '(byte-compile-file "scripts/playground-gui-scenarios.el")' \
|
||||
--eval '(byte-compile-file "scripts/research-shelf-m0a-evidence.el")' \
|
||||
--eval '(dolist (file (quote ($(foreach file,$(TEST_FILES),"$(file)")))) (byte-compile-file file))'
|
||||
|
||||
examples-read: compile
|
||||
@ -99,7 +100,7 @@ load: compile
|
||||
--eval '(princ "etaf-playground load OK\\n")'
|
||||
|
||||
checkdoc:
|
||||
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (append (list "etaf-playground.el" "scripts/benchmark-research-shelf.el" "scripts/playground-gui-scenarios.el") (directory-files-recursively "tests" "\\.el$$") (directory-files-recursively "examples" "\\.el$$"))) (checkdoc-file file)))'
|
||||
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (append (list "etaf-playground.el" "scripts/benchmark-research-shelf.el" "scripts/playground-gui-scenarios.el" "scripts/research-shelf-m0a-evidence.el") (directory-files-recursively "tests" "\\.el$$") (directory-files-recursively "examples" "\\.el$$"))) (checkdoc-file file)))'
|
||||
|
||||
check: checkdoc test
|
||||
|
||||
|
||||
870
scripts/research-shelf-m0a-evidence.el
Normal file
870
scripts/research-shelf-m0a-evidence.el
Normal file
@ -0,0 +1,870 @@
|
||||
;;; research-shelf-m0a-evidence.el --- Research Shelf M0a evidence -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
;; Reproducible current-behavior evidence for Research Shelf. Missing target
|
||||
;; observability is represented as `observed-gap'; no target counter is
|
||||
;; synthesized from elapsed time or inferred from unrelated provider fields.
|
||||
|
||||
;;; Code:
|
||||
(require 'cl-lib)
|
||||
(require 'seq)
|
||||
(require 'subr-x)
|
||||
(require 'etaf-playground)
|
||||
(require 'etaf-performance)
|
||||
|
||||
(defvar etaf-research-shelf-database-file)
|
||||
(defvar etaf-research-shelf-fixture-size)
|
||||
(defvar etaf-research-shelf-page-size)
|
||||
(declare-function etaf-research-shelf--database "../examples/research-shelf")
|
||||
(declare-function etaf-sqlite-source "etaf-sqlite")
|
||||
|
||||
(etaf-define-component etaf-playground-m0a-dependency-fixture (&key source)
|
||||
"Observe SOURCE while retaining equal semantic output."
|
||||
:view (text (expr (progn (etaf-value source) "same"))))
|
||||
|
||||
(defvar etaf-playground-m0a--database-label nil
|
||||
"Dynamic database basename redacted from reproducible evidence.")
|
||||
|
||||
(defvar etaf-playground-m0a--property-identities nil
|
||||
"Dynamic map used to canonicalize publication-local property identities.")
|
||||
|
||||
(defvar etaf-playground-m0a--next-property-identity 0
|
||||
"Next canonical property identity in the current evidence capture.")
|
||||
|
||||
(defconst etaf-playground-m0a--package-root
|
||||
(file-name-directory
|
||||
(directory-file-name
|
||||
(file-name-directory (or load-file-name buffer-file-name))))
|
||||
"Absolute etaf-playground package root used by M0a evidence.")
|
||||
|
||||
(defconst etaf-playground-m0a-evidence-schema
|
||||
'(:schema-version 1
|
||||
:evidence-mode observed-baseline
|
||||
:semantic
|
||||
(generation root-semantic-id identity-count handler-refs host-refs)
|
||||
:text-properties
|
||||
(text-sha256 property-runs-sha256 property-run-count property-names)
|
||||
:identity (range-identity-count handler-refs host-refs)
|
||||
:lifecycle (mounted unmounted buffer-killed)
|
||||
:sqlite (provider total item-ids result-sha256)
|
||||
:performance
|
||||
(operation-id operation-kind elapsed-ms generation-before generation-after
|
||||
provider-stages gc-count gc-duration-ms tp-text-operations
|
||||
tp-property-operations tp-reconciled-objects
|
||||
tp-created-objects tp-removed-objects tp-moved-objects
|
||||
tp-full-root tp-scope-count tp-scope-fallback dirty-count
|
||||
patch-count cost-class changed-sources queued-effects
|
||||
evaluated-effects turn-count turn-index turn-epoch
|
||||
semantic-nodes-visited semantic-nodes-changed
|
||||
semantic-nodes-reused
|
||||
semantic-nodes-created semantic-nodes-removed
|
||||
ebox-nodes-materialized full-path-reason
|
||||
candidate-index-node-visits candidate-index-node-copies
|
||||
candidate-effect-index-visits candidate-source-index-visits
|
||||
committed-generation-delta allocation)
|
||||
:gui-first-paint
|
||||
(:status observed-gap
|
||||
:reason no-action-start-to-forced-redisplay-complete-marker
|
||||
:activation before-performance-complete))
|
||||
"Versioned package-local M0a semantic and trace evidence schema.")
|
||||
|
||||
(defun etaf-playground-m0a--sha256 (value)
|
||||
"Return a stable SHA-256 digest for printed VALUE."
|
||||
(secure-hash 'sha256 (encode-coding-string (prin1-to-string value) 'utf-8)))
|
||||
|
||||
(defun etaf-playground-m0a--canonical-property-identity (value)
|
||||
"Return a stable encounter-order identity for publication-local VALUE."
|
||||
(or (gethash value etaf-playground-m0a--property-identities)
|
||||
(puthash value
|
||||
(prog1 etaf-playground-m0a--next-property-identity
|
||||
(setq etaf-playground-m0a--next-property-identity
|
||||
(1+ etaf-playground-m0a--next-property-identity)))
|
||||
etaf-playground-m0a--property-identities)))
|
||||
|
||||
(defun etaf-playground-m0a--canonical-paint-value (value)
|
||||
"Canonicalize publication-local TP paint slot symbols in VALUE."
|
||||
(cond
|
||||
((and (symbolp value)
|
||||
(string-match-p "\\`tp-paint-slot-[0-9]+\\'" (symbol-name value)))
|
||||
(list 'tp-paint-slot
|
||||
(etaf-playground-m0a--canonical-property-identity value)))
|
||||
((consp value)
|
||||
(cons (etaf-playground-m0a--canonical-paint-value (car value))
|
||||
(etaf-playground-m0a--canonical-paint-value (cdr value))))
|
||||
(t value)))
|
||||
|
||||
(defun etaf-playground-m0a--stable-property-value (value &optional property)
|
||||
"Return reproducible evidence for text property VALUE under PROPERTY."
|
||||
(cond
|
||||
((memq property '(ebox-content ebox-content-owner ebox-content-owners
|
||||
ebox-bb ebox-bl ebox-br ebox-bt
|
||||
ebox-pb ebox-pl ebox-pr ebox-pt
|
||||
ebox-region-id ebox-scroll-region-id))
|
||||
(if (consp value)
|
||||
(mapcar #'etaf-playground-m0a--canonical-property-identity value)
|
||||
(etaf-playground-m0a--canonical-property-identity value)))
|
||||
((eq property 'face)
|
||||
(etaf-playground-m0a--canonical-paint-value value))
|
||||
((and (symbolp value)
|
||||
(string-match-p "\\`tp-paint-slot-[0-9]+\\'" (symbol-name value)))
|
||||
(list 'tp-paint-slot
|
||||
(etaf-playground-m0a--canonical-property-identity value)))
|
||||
((stringp value)
|
||||
(if etaf-playground-m0a--database-label
|
||||
(replace-regexp-in-string
|
||||
(regexp-quote etaf-playground-m0a--database-label)
|
||||
"<database>" value t t)
|
||||
value))
|
||||
((or (null value) (numberp value) (symbolp value)) value)
|
||||
((and (consp value)
|
||||
(not (seq-some (lambda (item)
|
||||
(or (functionp item) (markerp item)
|
||||
(recordp item) (hash-table-p item)))
|
||||
(flatten-tree value))))
|
||||
value)
|
||||
((functionp value) '<function>)
|
||||
((markerp value) '<marker>)
|
||||
((hash-table-p value) '<hash-table>)
|
||||
((recordp value) (list '<record> (type-of value)))
|
||||
(t (list '<opaque> (type-of value)))))
|
||||
|
||||
(defun etaf-playground-m0a--property-runs (buffer)
|
||||
"Return normalized text-property runs from BUFFER."
|
||||
(with-current-buffer buffer
|
||||
(let ((position (point-min))
|
||||
(etaf-playground-m0a--property-identities
|
||||
(make-hash-table :test #'equal))
|
||||
(etaf-playground-m0a--next-property-identity 0)
|
||||
runs)
|
||||
(while (< position (point-max))
|
||||
(let* ((next (or (next-property-change position nil (point-max))
|
||||
(point-max)))
|
||||
(properties (text-properties-at position))
|
||||
normalized)
|
||||
(while properties
|
||||
(let ((property (pop properties))
|
||||
(value (pop properties)))
|
||||
(push (cons property
|
||||
(etaf-playground-m0a--stable-property-value
|
||||
value property))
|
||||
normalized)))
|
||||
(push (list :start (1- position) :end (1- next)
|
||||
:properties
|
||||
(sort normalized
|
||||
(lambda (left right)
|
||||
(string< (symbol-name (car left))
|
||||
(symbol-name (car right))))))
|
||||
runs)
|
||||
(setq position next)))
|
||||
(nreverse runs))))
|
||||
|
||||
(defun etaf-playground-m0a--stable-refs (entries)
|
||||
"Return stable symbol/string/number keys from public ENTRIES."
|
||||
(sort
|
||||
(delq nil
|
||||
(mapcar (lambda (entry)
|
||||
(let ((key (car entry)))
|
||||
(and (or (symbolp key) (stringp key) (numberp key)) key)))
|
||||
entries))
|
||||
(lambda (left right) (string< (format "%S" left) (format "%S" right)))))
|
||||
|
||||
(defun etaf-playground-m0a--semantic-evidence (runtime)
|
||||
"Return stable public semantic/identity evidence for RUNTIME."
|
||||
(let* ((generation (etaf-runtime-current-generation runtime))
|
||||
(identity-index (etaf-generation-identity-index generation))
|
||||
(range-count 0))
|
||||
(maphash (lambda (identity _semantic-id)
|
||||
(when (eq (car-safe identity) 'range)
|
||||
(setq range-count (1+ range-count))))
|
||||
identity-index)
|
||||
(list :generation (etaf-runtime-generation runtime)
|
||||
:root-semantic-id (etaf-generation-root-semantic-id generation)
|
||||
:identity-count (hash-table-count identity-index)
|
||||
:range-identity-count range-count
|
||||
:handler-refs
|
||||
(etaf-playground-m0a--stable-refs
|
||||
(etaf-runtime-handler-entries runtime))
|
||||
:host-refs
|
||||
(etaf-playground-m0a--stable-refs
|
||||
(etaf-runtime-host-props-entries runtime)))))
|
||||
|
||||
(defun etaf-playground-m0a--text-evidence (buffer)
|
||||
"Return stable text and text-property evidence from BUFFER."
|
||||
(with-current-buffer buffer
|
||||
(let* ((text (substring-no-properties (buffer-string)))
|
||||
(text (if etaf-playground-m0a--database-label
|
||||
(replace-regexp-in-string
|
||||
(regexp-quote etaf-playground-m0a--database-label)
|
||||
"<database>" text t t)
|
||||
text))
|
||||
(runs (etaf-playground-m0a--property-runs buffer))
|
||||
names)
|
||||
(dolist (run runs)
|
||||
(dolist (entry (plist-get run :properties))
|
||||
(cl-pushnew (car entry) names)))
|
||||
(list :text-sha256 (etaf-playground-m0a--sha256 text)
|
||||
:text-length (length text)
|
||||
:property-runs-sha256 (etaf-playground-m0a--sha256 runs)
|
||||
:property-run-count (length runs)
|
||||
:property-names
|
||||
(sort names (lambda (left right)
|
||||
(string< (symbol-name left) (symbol-name right))))))))
|
||||
|
||||
(defun etaf-playground-m0a--sqlite-evidence ()
|
||||
"Return stable Research Shelf SQLite result evidence."
|
||||
(let* ((source (etaf-sqlite-source (etaf-research-shelf--database)))
|
||||
(result (etaf-data-source-load-page source nil 1 8))
|
||||
(items (plist-get result :items))
|
||||
(canonical
|
||||
(mapcar
|
||||
(lambda (item)
|
||||
(mapcar (lambda (key) (cons key (plist-get item key)))
|
||||
'(:id :title :author :kind :status :progress :priority
|
||||
:starred :note :updated)))
|
||||
items)))
|
||||
(list :provider (plist-get source :provider)
|
||||
:total (plist-get result :total)
|
||||
:item-ids (mapcar (lambda (item) (plist-get item :id)) items)
|
||||
:result-sha256 (etaf-playground-m0a--sha256 canonical))))
|
||||
|
||||
(defun etaf-playground-m0a--metadata-field (operation keys)
|
||||
"Return `(FOUND . VALUE)' for the first of KEYS in OPERATION stages."
|
||||
(catch 'found
|
||||
(dolist (stage (etaf-performance-operation-stages operation))
|
||||
(let ((metadata (etaf-performance-stage-metadata stage)))
|
||||
(dolist (key keys)
|
||||
(when (plist-member metadata key)
|
||||
(throw 'found (cons t (plist-get metadata key)))))))
|
||||
(cons nil nil)))
|
||||
|
||||
(defun etaf-playground-m0a--observed (value)
|
||||
"Return an observed evidence cell for VALUE."
|
||||
(list :status 'observed :value value))
|
||||
|
||||
(defun etaf-playground-m0a--gap (reason)
|
||||
"Return an observed-gap evidence cell with REASON."
|
||||
(list :status 'observed-gap :reason reason))
|
||||
|
||||
(defun etaf-playground-m0a--metadata-evidence (operation name keys)
|
||||
"Return NAME evidence read from OPERATION metadata using KEYS."
|
||||
(let ((found (etaf-playground-m0a--metadata-field operation keys)))
|
||||
(cons name
|
||||
(if (car found)
|
||||
(etaf-playground-m0a--observed (cdr found))
|
||||
(etaf-playground-m0a--gap 'not-in-public-report)))))
|
||||
|
||||
(defun etaf-playground-m0a--metadata-present-p (operation keys)
|
||||
"Return non-nil when OPERATION reports a non-nil value under KEYS."
|
||||
(let ((found (etaf-playground-m0a--metadata-field operation keys)))
|
||||
(and (car found) (cdr found))))
|
||||
|
||||
(defun etaf-playground-m0a--zeroable-metadata-evidence
|
||||
(operation name keys provider)
|
||||
"Return numeric NAME from OPERATION KEYS, observing zero without PROVIDER.
|
||||
|
||||
The zero is not a synthesized span: the ordered public provider-stage list is
|
||||
the observation that PROVIDER did not participate in the operation."
|
||||
(let ((found (etaf-playground-m0a--metadata-field operation keys)))
|
||||
(cons name
|
||||
(cond
|
||||
((car found) (etaf-playground-m0a--observed (cdr found)))
|
||||
((not (seq-some
|
||||
(lambda (stage)
|
||||
(eq provider (etaf-performance-stage-provider stage)))
|
||||
(etaf-performance-operation-stages operation)))
|
||||
(append (etaf-playground-m0a--observed 0)
|
||||
(list :basis 'provider-stage-absent)))
|
||||
(t (etaf-playground-m0a--gap 'provider-stage-omits-counter))))))
|
||||
|
||||
(defun etaf-playground-m0a-performance-evidence (operation &optional allocation)
|
||||
"Return current public report fields and explicit gaps for OPERATION.
|
||||
ALLOCATION is the harness-owned before/after allocation observation."
|
||||
(append
|
||||
(list
|
||||
(cons 'operation-id
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-id operation)))
|
||||
(cons 'operation-kind
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-kind operation)))
|
||||
(cons 'elapsed-ms
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-elapsed operation)))
|
||||
(cons 'generation-before
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-generation-before operation)))
|
||||
(cons 'generation-after
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-generation-after operation)))
|
||||
(cons 'provider-stages
|
||||
(etaf-playground-m0a--observed
|
||||
(mapcar (lambda (stage)
|
||||
(cons (etaf-performance-stage-category stage)
|
||||
(etaf-performance-stage-name stage)))
|
||||
(etaf-performance-operation-stages operation))))
|
||||
(cons 'gc-count
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-gc-count operation)))
|
||||
(cons 'gc-duration-ms
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-gc-elapsed operation))))
|
||||
(mapcar
|
||||
(lambda (spec)
|
||||
(etaf-playground-m0a--zeroable-metadata-evidence
|
||||
operation (car spec) (cdr spec) 'tp))
|
||||
'((tp-text-operations :tp-text-operations :text-operations)
|
||||
(tp-property-operations :tp-property-operations :property-operations)
|
||||
(tp-reconciled-objects :reconciled-objects)
|
||||
(tp-created-objects :created-objects)
|
||||
(tp-removed-objects :removed-objects)
|
||||
(tp-moved-objects :moved-objects)))
|
||||
(mapcar
|
||||
(lambda (spec)
|
||||
(etaf-playground-m0a--metadata-evidence operation (car spec) (cdr spec)))
|
||||
'((tp-full-root :tp-full-root :full-root)
|
||||
(tp-scope-count :tp-scope-count :scope-count)
|
||||
(tp-scope-fallback :tp-scope-fallback :scope-fallback)
|
||||
(dirty-count :dirty-count)
|
||||
(patch-count :patch-count)))
|
||||
(list
|
||||
(cons 'allocation
|
||||
(if allocation
|
||||
(etaf-playground-m0a--observed allocation)
|
||||
(etaf-playground-m0a--gap 'not-measured-by-caller))))))
|
||||
|
||||
(defun etaf-playground-m0a--work-probe-create ()
|
||||
"Return empty operation-local current-work instrumentation."
|
||||
(list :changed-sources (make-hash-table :test #'eql)
|
||||
:queued-effects (make-hash-table :test #'eql)
|
||||
:evaluated-effects nil :turns nil
|
||||
:semantic-nodes-visited 0 :semantic-nodes-changed 0
|
||||
:semantic-nodes-reused 0 :semantic-nodes-created 0
|
||||
:semantic-nodes-removed 0 :ebox-nodes-materialized 0
|
||||
:full-generation-p nil))
|
||||
|
||||
(defun etaf-playground-m0a--probe-increment (probe key &optional amount)
|
||||
"Increment PROBE numeric KEY by AMOUNT, defaulting to one."
|
||||
(plist-put probe key (+ (or (plist-get probe key) 0) (or amount 1))))
|
||||
|
||||
(defun etaf-playground-m0a--probe-semantic-generation
|
||||
(probe runtime base generation)
|
||||
"Record exact candidate classifications for RUNTIME into PROBE.
|
||||
BASE and GENERATION are the committed generations bracketing the candidate."
|
||||
(let ((candidate (etaf-runtime-candidate-graph-nodes runtime))
|
||||
(removed (etaf-runtime-candidate-removed-semantic-ids runtime)))
|
||||
(when (hash-table-p candidate)
|
||||
(maphash
|
||||
(lambda (semantic-id semantic)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-visited)
|
||||
(let ((old (and base
|
||||
(etaf--pvec-get
|
||||
(etaf-generation-semantic-nodes base) semantic-id))))
|
||||
(cond
|
||||
((null old)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-created))
|
||||
((equal-including-properties old semantic)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-reused))
|
||||
(t
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-changed)))))
|
||||
candidate))
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-removed (length removed))
|
||||
(when (etaf-runtime-candidate-full-rebuild-p runtime)
|
||||
(plist-put probe :full-generation-p t))
|
||||
generation))
|
||||
|
||||
(defun etaf-playground-m0a--call-with-work-probe (runtime function)
|
||||
"Call FUNCTION with operation-local current-work counters for RUNTIME.
|
||||
Return `(RESULT . PROBE)'. Counters observe existing internal boundaries;
|
||||
they neither alter scheduling nor add a product reporting contract."
|
||||
(let* ((probe (etaf-playground-m0a--work-probe-create))
|
||||
(route-scheduler (symbol-function 'etaf--runtime-route-scheduler))
|
||||
(enqueue-effect (symbol-function 'etaf--runtime-enqueue-effect))
|
||||
(record-effect (symbol-function
|
||||
'etaf--runtime-record-effect-input-version))
|
||||
(component-turn (symbol-function 'etaf--runtime-component-overlay))
|
||||
(root-turn (symbol-function 'etaf--runtime-render-root-turn))
|
||||
(build-generation (symbol-function 'etaf--runtime-build-generation))
|
||||
(text-node (symbol-function 'etaf--ebox-text-node))
|
||||
(box-node (symbol-function 'etaf--ebox-box-node))
|
||||
result)
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf--runtime-route-scheduler)
|
||||
(lambda (route source)
|
||||
(when (= (etaf-runtime-route-mount-epoch route)
|
||||
(etaf-runtime-mount-epoch runtime))
|
||||
(puthash (etaf-reactive-source-id source) t
|
||||
(plist-get probe :changed-sources)))
|
||||
(funcall route-scheduler route source)))
|
||||
((symbol-function 'etaf--runtime-enqueue-effect)
|
||||
(lambda (owner effect-id)
|
||||
(let ((new-p (and (eq owner runtime)
|
||||
(not (gethash
|
||||
effect-id
|
||||
(etaf-runtime-dirty-effect-ids owner))))))
|
||||
(prog1 (funcall enqueue-effect owner effect-id)
|
||||
(when new-p
|
||||
(puthash effect-id t (plist-get probe :queued-effects)))))))
|
||||
((symbol-function 'etaf--runtime-record-effect-input-version)
|
||||
(lambda (owner generation effect-id)
|
||||
(when (eq owner runtime)
|
||||
(push effect-id (plist-get probe :evaluated-effects)))
|
||||
(funcall record-effect owner generation effect-id)))
|
||||
((symbol-function 'etaf--runtime-component-overlay)
|
||||
(lambda (owner)
|
||||
(when (eq owner runtime)
|
||||
(push (list :kind 'component-overlay
|
||||
:epoch (etaf-runtime-generation owner))
|
||||
(plist-get probe :turns)))
|
||||
(funcall component-turn owner)))
|
||||
((symbol-function 'etaf--runtime-render-root-turn)
|
||||
(lambda (owner &optional force-components-p)
|
||||
(when (eq owner runtime)
|
||||
(push (list :kind 'root
|
||||
:epoch (etaf-runtime-generation owner))
|
||||
(plist-get probe :turns)))
|
||||
(funcall root-turn owner force-components-p)))
|
||||
((symbol-function 'etaf--runtime-build-generation)
|
||||
(lambda (owner &optional base)
|
||||
(let ((generation (funcall build-generation owner base)))
|
||||
(when (eq owner runtime)
|
||||
(etaf-playground-m0a--probe-semantic-generation
|
||||
probe owner base generation))
|
||||
generation)))
|
||||
((symbol-function 'etaf--ebox-text-node)
|
||||
(lambda (&rest args)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :ebox-nodes-materialized)
|
||||
(apply text-node args)))
|
||||
((symbol-function 'etaf--ebox-box-node)
|
||||
(lambda (&rest args)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :ebox-nodes-materialized)
|
||||
(apply box-node args))))
|
||||
(setq result (funcall function)))
|
||||
(cons result probe)))
|
||||
|
||||
(defun etaf-playground-m0a--probe-set-value (table)
|
||||
"Return sorted numeric keys observed in hash TABLE."
|
||||
(let (values)
|
||||
(maphash (lambda (key _value) (push key values)) table)
|
||||
(sort values #'<)))
|
||||
|
||||
(defun etaf-playground-m0a--work-evidence
|
||||
(operation category probe)
|
||||
"Return M0a current-work evidence for OPERATION, CATEGORY, and PROBE."
|
||||
(let* ((turns (nreverse (plist-get probe :turns)))
|
||||
(changed
|
||||
(etaf-playground-m0a--probe-set-value
|
||||
(plist-get probe :changed-sources)))
|
||||
(queued
|
||||
(etaf-playground-m0a--probe-set-value
|
||||
(plist-get probe :queued-effects)))
|
||||
(evaluated (nreverse (plist-get probe :evaluated-effects)))
|
||||
(public-full-p
|
||||
(etaf-playground-m0a--metadata-present-p
|
||||
operation '(:tp-full-root :full-root :full-rerender)))
|
||||
(full-p (or (plist-get probe :full-generation-p) public-full-p))
|
||||
(cost-class
|
||||
(cond
|
||||
(full-p 'full)
|
||||
((eq category 'data-mutation) "scope(collection)")
|
||||
((memq category '(semantic-style viewport-scroll scroll))
|
||||
"scope(subtree/owners)")
|
||||
((or changed
|
||||
(> (etaf-performance-operation-generation-after operation)
|
||||
(etaf-performance-operation-generation-before operation)))
|
||||
'delta)
|
||||
(t 'no-op)))
|
||||
(full-reason
|
||||
(if full-p
|
||||
(or (cdr (etaf-playground-m0a--metadata-field
|
||||
operation '(:native-fallback-reason
|
||||
:full-path-reason :fallback-reason)))
|
||||
(and (plist-get probe :full-generation-p)
|
||||
'runtime-candidate-full-rebuild)
|
||||
(and public-full-p 'public-full-root-publication))
|
||||
'not-full-path)))
|
||||
(list
|
||||
(cons 'cost-class (etaf-playground-m0a--observed cost-class))
|
||||
(cons 'changed-sources
|
||||
(etaf-playground-m0a--observed
|
||||
(list :count (length changed) :ids changed)))
|
||||
(cons 'queued-effects
|
||||
(etaf-playground-m0a--observed
|
||||
(list :count (length queued) :ids queued)))
|
||||
(cons 'evaluated-effects
|
||||
(etaf-playground-m0a--observed
|
||||
(list :count (length evaluated) :ids evaluated)))
|
||||
(cons 'turn-count
|
||||
(etaf-playground-m0a--observed (length turns)))
|
||||
(cons 'turn-index
|
||||
(etaf-playground-m0a--observed
|
||||
(number-sequence 1 (length turns))))
|
||||
(cons 'turn-epoch
|
||||
(etaf-playground-m0a--observed
|
||||
(mapcar (lambda (turn) (plist-get turn :epoch)) turns)))
|
||||
(cons 'semantic-nodes-visited
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-visited)))
|
||||
(cons 'semantic-nodes-changed
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-changed)))
|
||||
(cons 'semantic-nodes-reused
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-reused)))
|
||||
(cons 'semantic-nodes-created
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-created)))
|
||||
(cons 'semantic-nodes-removed
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-removed)))
|
||||
(cons 'ebox-nodes-materialized
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :ebox-nodes-materialized)))
|
||||
(cons 'full-path-reason
|
||||
(etaf-playground-m0a--observed full-reason)))))
|
||||
|
||||
(defun etaf-playground-m0a--allocation-observation (before after)
|
||||
"Return raw BEFORE/AFTER `memory-use-counts' plus numeric deltas."
|
||||
(list :api 'memory-use-counts
|
||||
:before before :after after
|
||||
:delta
|
||||
(cl-mapcar (lambda (left right)
|
||||
(and (numberp left) (numberp right) (- right left)))
|
||||
before after)))
|
||||
|
||||
(defun etaf-playground-m0a--candidate-metric-evidence
|
||||
(runtime generation-before generation-after)
|
||||
"Return candidate metrics for RUNTIME from GENERATION-BEFORE to GENERATION-AFTER."
|
||||
(let ((names '(candidate-index-node-visits candidate-index-node-copies
|
||||
candidate-effect-index-visits
|
||||
candidate-source-index-visits)))
|
||||
(if (<= generation-after generation-before)
|
||||
(mapcar (lambda (name)
|
||||
(cons name
|
||||
(etaf-playground-m0a--gap
|
||||
'no-candidate-generation-in-operation)))
|
||||
names)
|
||||
(let ((metrics (etaf-runtime-candidate-generation-metrics runtime)))
|
||||
(if (null metrics)
|
||||
(mapcar (lambda (name)
|
||||
(cons name
|
||||
(etaf-playground-m0a--gap
|
||||
'candidate-metrics-unavailable)))
|
||||
names)
|
||||
(list
|
||||
(cons 'candidate-index-node-visits
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf--generation-metrics-node-visits metrics)))
|
||||
(cons 'candidate-index-node-copies
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf--generation-metrics-node-copies metrics)))
|
||||
(cons 'candidate-effect-index-visits
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf--generation-metrics-effect-visits metrics)))
|
||||
(cons 'candidate-source-index-visits
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf--generation-metrics-source-visits metrics)))))))))
|
||||
|
||||
(defun etaf-playground-m0a--trace-operation
|
||||
(runtime scenario category function)
|
||||
"Run FUNCTION as SCENARIO on RUNTIME and return CATEGORY evidence."
|
||||
(let* ((before (car (etaf-performance-records)))
|
||||
(before-id (and before (etaf-performance-operation-id before)))
|
||||
(allocation-before (memory-use-counts))
|
||||
(observed
|
||||
(etaf-playground-m0a--call-with-work-probe
|
||||
runtime
|
||||
(lambda ()
|
||||
(etaf-performance-call-operation
|
||||
runtime 'm0a-trace scenario function))))
|
||||
(result (car observed))
|
||||
(probe (cdr observed))
|
||||
(allocation-after (memory-use-counts)))
|
||||
(let ((operation (car (etaf-performance-records))))
|
||||
(unless (and operation
|
||||
(not (equal before-id
|
||||
(etaf-performance-operation-id operation)))
|
||||
(equal scenario
|
||||
(etaf-performance-operation-label operation)))
|
||||
(error "M0a scenario %s did not emit one public operation" scenario))
|
||||
(let* ((generation-before
|
||||
(etaf-performance-operation-generation-before operation))
|
||||
(generation-after
|
||||
(etaf-performance-operation-generation-after operation))
|
||||
(fields
|
||||
(append
|
||||
(etaf-playground-m0a-performance-evidence
|
||||
operation
|
||||
(etaf-playground-m0a--allocation-observation
|
||||
allocation-before allocation-after))
|
||||
(etaf-playground-m0a--work-evidence
|
||||
operation category probe)
|
||||
(etaf-playground-m0a--candidate-metric-evidence
|
||||
runtime generation-before generation-after)
|
||||
(list
|
||||
(cons 'committed-generation-delta
|
||||
(etaf-playground-m0a--observed
|
||||
(- generation-after generation-before)))))))
|
||||
(list :scenario-id (intern scenario)
|
||||
:category category
|
||||
:operation-label (etaf-performance-operation-label operation)
|
||||
:operation-kind (etaf-performance-operation-kind operation)
|
||||
:result result
|
||||
:public-report-fields fields
|
||||
:gui-first-paint
|
||||
(plist-get etaf-playground-m0a-evidence-schema
|
||||
:gui-first-paint))))))
|
||||
|
||||
(defun etaf-playground-m0a--dependency-only-scenario ()
|
||||
"Capture one equal-output dependency-only scenario."
|
||||
(let ((buffer (generate-new-buffer-name " *etaf-m0a-dependency*"))
|
||||
(source (etaf-ref 0)) runtime evidence)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-view
|
||||
(etaf-playground-m0a-dependency-fixture :source source)))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer))
|
||||
(etaf-performance-clear)
|
||||
(etaf-performance-start runtime)
|
||||
(setq evidence
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "dependency-only" 'dependency-only
|
||||
(lambda () (setf (etaf-value source) 1))))
|
||||
(etaf-performance-stop runtime))
|
||||
(when (and runtime (etaf-runtime-mounted-p runtime))
|
||||
(ignore-errors (etaf-performance-stop runtime))
|
||||
(etaf-unmount runtime))
|
||||
(when (get-buffer buffer) (kill-buffer buffer)))
|
||||
evidence))
|
||||
|
||||
(defun etaf-playground-m0a--scroll-property-position (buffer)
|
||||
"Return a BUFFER position carrying an Ebox scroll-window identity."
|
||||
(with-current-buffer buffer
|
||||
(let ((position (point-min)) found)
|
||||
(while (and (< position (point-max)) (not found))
|
||||
(when (get-text-property position 'ebox-scroll-window)
|
||||
(setq found position))
|
||||
(setq position
|
||||
(or (next-single-property-change
|
||||
position 'ebox-scroll-window nil (point-max))
|
||||
(point-max))))
|
||||
found)))
|
||||
|
||||
(defun etaf-playground-m0a--scroll-scenario ()
|
||||
"Capture one real public scroll operation."
|
||||
(let ((buffer (generate-new-buffer-name " *etaf-m0a-scroll*"))
|
||||
runtime evidence)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-view
|
||||
(column :height 3 :overflow 'scroll
|
||||
(box "line-1") (box "line-2") (box "line-3")
|
||||
(box "line-4") (box "line-5") (box "line-6"))))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer))
|
||||
(let* ((position (etaf-playground-m0a--scroll-property-position
|
||||
buffer))
|
||||
(region-id
|
||||
(and position
|
||||
(with-current-buffer buffer
|
||||
(get-text-property position 'ebox-scroll-window))))
|
||||
(before (and region-id
|
||||
(plist-get (ebox-scroll-state region-id)
|
||||
:scroll-offset))))
|
||||
(unless (and position region-id (numberp before))
|
||||
(error "M0a scroll fixture did not publish a scroll owner"))
|
||||
(etaf-performance-clear)
|
||||
(etaf-performance-start runtime)
|
||||
(setq evidence
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "public-scroll" 'scroll
|
||||
(lambda ()
|
||||
(with-current-buffer buffer
|
||||
(goto-char position)
|
||||
(ebox-scroll-down 1)))))
|
||||
(let ((after (plist-get (ebox-scroll-state region-id)
|
||||
:scroll-offset)))
|
||||
(unless (> after before)
|
||||
(error "M0a public scroll did not advance its owner"))
|
||||
(setq evidence
|
||||
(plist-put evidence :current-facts
|
||||
(list :region-id-present t
|
||||
:offset-before before
|
||||
:offset-after after))))
|
||||
(etaf-performance-stop runtime)))
|
||||
(when (and runtime (etaf-runtime-mounted-p runtime))
|
||||
(ignore-errors (etaf-performance-stop runtime))
|
||||
(etaf-unmount runtime))
|
||||
(when (get-buffer buffer) (kill-buffer buffer)))
|
||||
evidence))
|
||||
|
||||
(defun etaf-playground-m0a--load-app ()
|
||||
"Load the Research Shelf companion from the package root."
|
||||
(unless (featurep 'etaf-research-shelf)
|
||||
(load-file (expand-file-name "examples/research-shelf.el"
|
||||
etaf-playground-m0a--package-root))))
|
||||
|
||||
(defun etaf-playground-m0a-capture-baseline (database buffer)
|
||||
"Capture one complete deterministic baseline using DATABASE and BUFFER."
|
||||
(etaf-playground-m0a--load-app)
|
||||
(let ((default-directory etaf-playground-m0a--package-root)
|
||||
(etaf-research-shelf-database-file database)
|
||||
(etaf-research-shelf-fixture-size 256)
|
||||
(etaf-research-shelf-page-size 12)
|
||||
(etaf-playground-m0a--database-label
|
||||
(file-name-nondirectory database))
|
||||
runtime semantic text sqlite lifecycle result matrix)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-playground-mount-example
|
||||
buffer "research-shelf" nil
|
||||
'(:viewport-width 1400 :viewport-height 80))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer)
|
||||
lifecycle (list (list :event 'mounted
|
||||
:runtime-mounted t :buffer-live t)))
|
||||
(etaf-performance-clear)
|
||||
(etaf-performance-start runtime)
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-1 'press)
|
||||
(push
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "data-mutation" 'data-mutation
|
||||
(lambda ()
|
||||
(etaf-dispatch-event runtime 'research-shelf-progress 'press)))
|
||||
matrix)
|
||||
(push
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "semantic-style-theme" 'semantic-style
|
||||
(lambda ()
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-theme-toggle 'press)))
|
||||
matrix)
|
||||
(push
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "viewport-resize" 'viewport-scroll
|
||||
(lambda ()
|
||||
(ebox-rerender-buffer-with-context (get-buffer buffer) 720 80)))
|
||||
matrix)
|
||||
(setq semantic (etaf-playground-m0a--semantic-evidence runtime)
|
||||
text (etaf-playground-m0a--text-evidence buffer)
|
||||
sqlite (etaf-playground-m0a--sqlite-evidence))
|
||||
(delete-file database)
|
||||
(let ((controller
|
||||
(etaf-data-controller
|
||||
(etaf-sqlite-source (etaf-research-shelf--database))
|
||||
:auto-load nil :name 'm0a-load-error)))
|
||||
(unwind-protect
|
||||
(push
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "data-load-error" 'data-load-error
|
||||
(lambda ()
|
||||
(condition-case condition
|
||||
(etaf-data-load controller)
|
||||
(error (list :condition (car condition))))))
|
||||
matrix)
|
||||
(etaf-data-stop controller)))
|
||||
(etaf-performance-stop runtime)
|
||||
(etaf-playground-close buffer)
|
||||
(setq lifecycle
|
||||
(append lifecycle
|
||||
(list (list :event 'unmounted :runtime-mounted nil)
|
||||
(list :event 'buffer-killed :buffer-live nil))))
|
||||
(setq result
|
||||
(list :schema-version 1
|
||||
:semantic semantic :text-properties text
|
||||
:identity
|
||||
(list :range-identity-count
|
||||
(plist-get semantic :range-identity-count)
|
||||
:handler-refs (plist-get semantic :handler-refs)
|
||||
:host-refs (plist-get semantic :host-refs))
|
||||
:lifecycle lifecycle :sqlite sqlite
|
||||
:performance
|
||||
(list
|
||||
:scenario-matrix
|
||||
(append
|
||||
(nreverse matrix)
|
||||
(list
|
||||
(etaf-playground-m0a--dependency-only-scenario)
|
||||
(etaf-playground-m0a--scroll-scenario))))
|
||||
:gui-first-paint
|
||||
(plist-get etaf-playground-m0a-evidence-schema
|
||||
:gui-first-paint))))
|
||||
(when (and runtime (etaf-runtime-mounted-p runtime))
|
||||
(ignore-errors (etaf-performance-stop runtime))
|
||||
(ignore-errors (etaf-unmount runtime)))
|
||||
(when (get-buffer buffer)
|
||||
(kill-buffer buffer)))
|
||||
result))
|
||||
|
||||
(defconst etaf-playground-m0a--required-work-fields
|
||||
'(cost-class changed-sources queued-effects evaluated-effects turn-count
|
||||
turn-index turn-epoch semantic-nodes-visited
|
||||
semantic-nodes-changed semantic-nodes-reused
|
||||
semantic-nodes-created semantic-nodes-removed
|
||||
ebox-nodes-materialized full-path-reason
|
||||
tp-text-operations tp-property-operations
|
||||
tp-reconciled-objects tp-created-objects
|
||||
tp-removed-objects tp-moved-objects allocation)
|
||||
"Fields that every representative M0a operation must actually observe.")
|
||||
|
||||
(defun etaf-playground-m0a--required-work-observed-p (baseline)
|
||||
"Return non-nil when every representative operation in BASELINE is observed."
|
||||
(cl-every
|
||||
(lambda (scenario)
|
||||
(let ((fields (plist-get scenario :public-report-fields)))
|
||||
(cl-every
|
||||
(lambda (name)
|
||||
(eq 'observed (plist-get (cdr (assq name fields)) :status)))
|
||||
etaf-playground-m0a--required-work-fields)))
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix)))
|
||||
|
||||
(defun etaf-playground-m0a-capture-baseline-batch ()
|
||||
"Write a fresh semantic/trace baseline and JSON metadata from environment.
|
||||
`ETAF_M0A_SEMANTIC_OUTPUT' names the raw printed Lisp artifact and
|
||||
`ETAF_M0A_SEMANTIC_METADATA' names its machine-readable summary."
|
||||
(let ((output (or (getenv "ETAF_M0A_SEMANTIC_OUTPUT")
|
||||
(error "ETAF_M0A_SEMANTIC_OUTPUT is not configured")))
|
||||
(metadata (or (getenv "ETAF_M0A_SEMANTIC_METADATA")
|
||||
(error "ETAF_M0A_SEMANTIC_METADATA is not configured")))
|
||||
(database (make-temp-file "research-shelf-m0a-batch-" nil ".sqlite"))
|
||||
(buffer (generate-new-buffer-name " *research-shelf-m0a-batch*")))
|
||||
(unwind-protect
|
||||
(let* ((baseline
|
||||
(etaf-playground-m0a-capture-baseline database buffer))
|
||||
(matrix
|
||||
(plist-get (plist-get baseline :performance)
|
||||
:scenario-matrix))
|
||||
(observed-p
|
||||
(etaf-playground-m0a--required-work-observed-p baseline)))
|
||||
(unless observed-p
|
||||
(error "M0a semantic evidence has unobserved required work"))
|
||||
(make-directory (file-name-directory output) t)
|
||||
(make-directory (file-name-directory metadata) t)
|
||||
(with-temp-file output
|
||||
(let ((print-circle t) (print-length nil) (print-level nil))
|
||||
(prin1 baseline (current-buffer))
|
||||
(insert "\n")))
|
||||
(with-temp-file metadata
|
||||
(insert
|
||||
(json-serialize
|
||||
`((schema_version . 1)
|
||||
(scenario_count . ,(length matrix))
|
||||
(required_work_fields_observed . t)
|
||||
(semantic_artifact . ,(file-name-nondirectory output)))))
|
||||
(insert "\n"))
|
||||
(princ (format "semantic-evidence-scenarios=%d required-work=observed\n"
|
||||
(length matrix)))
|
||||
t)
|
||||
(when (get-buffer buffer) (kill-buffer buffer))
|
||||
(when (file-exists-p database) (delete-file database)))))
|
||||
|
||||
(provide 'research-shelf-m0a-evidence)
|
||||
;;; research-shelf-m0a-evidence.el ends here
|
||||
240
tests/research-shelf-m0a-evidence-tests.el
Normal file
240
tests/research-shelf-m0a-evidence-tests.el
Normal file
@ -0,0 +1,240 @@
|
||||
;;; research-shelf-m0a-evidence-tests.el --- Research Shelf M0a tests -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
(require 'ert)
|
||||
(defvar etaf-playground-m0a-evidence-schema)
|
||||
(declare-function etaf-playground-m0a-capture-baseline
|
||||
"../scripts/research-shelf-m0a-evidence")
|
||||
(declare-function etaf-playground-m0a-capture-baseline-batch
|
||||
"../scripts/research-shelf-m0a-evidence")
|
||||
(load-file (expand-file-name "scripts/research-shelf-m0a-evidence.el"
|
||||
default-directory))
|
||||
|
||||
(defmacro etaf-playground-m0a-test--with-baseline (variable &rest body)
|
||||
"Bind VARIABLE to a fresh Research Shelf baseline while running BODY."
|
||||
(declare (indent 1))
|
||||
`(let ((database (make-temp-file "research-shelf-m0a-" nil ".sqlite"))
|
||||
(buffer (generate-new-buffer-name " *research-shelf-m0a*")))
|
||||
(unwind-protect
|
||||
(let ((,variable
|
||||
(etaf-playground-m0a-capture-baseline database buffer)))
|
||||
,@body)
|
||||
(when (get-buffer buffer) (kill-buffer buffer))
|
||||
(when (file-exists-p database) (delete-file database)))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-schema-separates-evidence-lanes ()
|
||||
"Define package-local semantic/trace evidence without conflating GUI timing."
|
||||
(dolist (key '(:semantic :text-properties :identity :lifecycle :sqlite
|
||||
:performance :gui-first-paint))
|
||||
(should (plist-member etaf-playground-m0a-evidence-schema key)))
|
||||
(should
|
||||
(eq 'observed-gap
|
||||
(plist-get
|
||||
(plist-get etaf-playground-m0a-evidence-schema :gui-first-paint)
|
||||
:status))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-baseline-captures-five-current-contracts ()
|
||||
"Capture semantic, text/property, identity, lifecycle, and SQLite evidence."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(should (= 64 (length (plist-get (plist-get baseline :text-properties)
|
||||
:text-sha256))))
|
||||
(should (> (plist-get (plist-get baseline :text-properties)
|
||||
:property-run-count)
|
||||
0))
|
||||
(should (> (plist-get (plist-get baseline :semantic) :identity-count) 0))
|
||||
(should (memq 'research-shelf-row-2
|
||||
(plist-get (plist-get baseline :identity) :handler-refs)))
|
||||
(should (equal '(mounted unmounted buffer-killed)
|
||||
(mapcar (lambda (entry) (plist-get entry :event))
|
||||
(plist-get baseline :lifecycle))))
|
||||
(should (equal 'sqlite
|
||||
(plist-get (plist-get baseline :sqlite) :provider)))
|
||||
(should (= 256 (plist-get (plist-get baseline :sqlite) :total)))
|
||||
(should (equal '(1 2 3 4 5 6 7 8)
|
||||
(plist-get (plist-get baseline :sqlite) :item-ids)))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-records-observed-public-fields ()
|
||||
"Record fields actually obtainable for every current scenario report."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(dolist (scenario
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(let ((performance (plist-get scenario :public-report-fields)))
|
||||
(dolist (field '(operation-id operation-kind elapsed-ms
|
||||
generation-before generation-after
|
||||
provider-stages gc-count gc-duration-ms))
|
||||
(should (eq 'observed (plist-get (cdr (assq field performance))
|
||||
:status))))
|
||||
(dolist (field '(tp-text-operations tp-property-operations
|
||||
tp-reconciled-objects
|
||||
tp-created-objects
|
||||
tp-removed-objects tp-moved-objects
|
||||
tp-full-root tp-scope-count
|
||||
tp-scope-fallback dirty-count
|
||||
patch-count))
|
||||
(should (memq (plist-get (cdr (assq field performance)) :status)
|
||||
'(observed observed-gap))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-observes-required-work-fields ()
|
||||
"Observe current cost, reactive turn, and semantic work for every scenario."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(dolist (scenario
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(let ((performance (plist-get scenario :public-report-fields)))
|
||||
(dolist (field '(cost-class changed-sources queued-effects
|
||||
evaluated-effects turn-count turn-index
|
||||
turn-epoch semantic-nodes-visited
|
||||
semantic-nodes-changed
|
||||
semantic-nodes-reused semantic-nodes-created
|
||||
semantic-nodes-removed
|
||||
ebox-nodes-materialized full-path-reason))
|
||||
(should (eq 'observed
|
||||
(plist-get (cdr (assq field performance)) :status))))
|
||||
(dolist (field '(turn-count semantic-nodes-visited
|
||||
semantic-nodes-changed
|
||||
semantic-nodes-reused semantic-nodes-created
|
||||
semantic-nodes-removed
|
||||
ebox-nodes-materialized))
|
||||
(should (natnump
|
||||
(plist-get (cdr (assq field performance)) :value))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-observes-tp-zero-work ()
|
||||
"Distinguish a non-participating TP stage from missing observation."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(dolist (scenario
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(let ((performance (plist-get scenario :public-report-fields)))
|
||||
(dolist (field '(tp-text-operations tp-property-operations
|
||||
tp-reconciled-objects
|
||||
tp-created-objects
|
||||
tp-removed-objects tp-moved-objects))
|
||||
(should (eq 'observed
|
||||
(plist-get (cdr (assq field performance)) :status)))
|
||||
(should (natnump
|
||||
(plist-get (cdr (assq field performance)) :value))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-work-counters-are-self-consistent ()
|
||||
"Lock the harness counter identities without imposing future budgets."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(dolist (scenario
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(let* ((fields (plist-get scenario :public-report-fields))
|
||||
(value (lambda (field)
|
||||
(plist-get (cdr (assq field fields)) :value)))
|
||||
(changed (funcall value 'changed-sources))
|
||||
(queued (funcall value 'queued-effects))
|
||||
(evaluated (funcall value 'evaluated-effects))
|
||||
(visited (funcall value 'semantic-nodes-visited)))
|
||||
(should (= (plist-get changed :count)
|
||||
(length (plist-get changed :ids))))
|
||||
(should (= (plist-get queued :count)
|
||||
(length (plist-get queued :ids))))
|
||||
(should (= (plist-get evaluated :count)
|
||||
(length (plist-get evaluated :ids))))
|
||||
(should (= (funcall value 'turn-count)
|
||||
(length (funcall value 'turn-index))))
|
||||
(should (= (funcall value 'turn-count)
|
||||
(length (funcall value 'turn-epoch))))
|
||||
(should (= visited
|
||||
(+ (funcall value 'semantic-nodes-changed)
|
||||
(funcall value 'semantic-nodes-reused)
|
||||
(funcall value 'semantic-nodes-created))))
|
||||
(should (or (eq 'not-full-path
|
||||
(funcall value 'full-path-reason))
|
||||
(eq 'full (funcall value 'cost-class))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-covers-required-scenario-matrix ()
|
||||
"Cover Data, style, viewport, and dependency-only current paths."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(let ((matrix
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix)))
|
||||
(should
|
||||
(equal '(data-mutation semantic-style viewport-scroll data-load-error
|
||||
dependency-only scroll)
|
||||
(mapcar (lambda (scenario) (plist-get scenario :category))
|
||||
matrix)))
|
||||
(dolist (scenario matrix)
|
||||
(should (eq 'm0a-trace (plist-get scenario :operation-kind)))
|
||||
(should (stringp (plist-get scenario :operation-label)))
|
||||
(should (eq 'observed-gap
|
||||
(plist-get (plist-get scenario :gui-first-paint)
|
||||
:status)))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-observes-allocation-and-metrics ()
|
||||
"Observe harness allocation and honest candidate-index metrics."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(let ((matrix
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix)))
|
||||
(dolist (scenario matrix)
|
||||
(let* ((fields (plist-get scenario :public-report-fields))
|
||||
(allocation (cdr (assq 'allocation fields))))
|
||||
(should (eq 'observed (plist-get allocation :status)))
|
||||
(should (eq 'memory-use-counts
|
||||
(plist-get (plist-get allocation :value) :api)))
|
||||
(should (listp (plist-get (plist-get allocation :value) :delta)))))
|
||||
(let* ((mutation (car matrix))
|
||||
(fields (plist-get mutation :public-report-fields)))
|
||||
(dolist (field '(candidate-index-node-visits
|
||||
candidate-index-node-copies
|
||||
candidate-effect-index-visits
|
||||
candidate-source-index-visits
|
||||
committed-generation-delta))
|
||||
(should (eq 'observed
|
||||
(plist-get (cdr (assq field fields)) :status))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-load-error-and-scroll-lock-current-facts ()
|
||||
"Lock isolated load-error facts and a real advancing public scroll owner."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(let* ((matrix
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(load-error
|
||||
(seq-find (lambda (scenario)
|
||||
(eq 'data-load-error
|
||||
(plist-get scenario :category)))
|
||||
matrix))
|
||||
(scroll
|
||||
(seq-find (lambda (scenario)
|
||||
(eq 'scroll (plist-get scenario :category)))
|
||||
matrix))
|
||||
(load-fields (plist-get load-error :public-report-fields)))
|
||||
(should (symbolp (plist-get (plist-get load-error :result) :condition)))
|
||||
(should
|
||||
(= (plist-get (cdr (assq 'generation-before load-fields)) :value)
|
||||
(plist-get (cdr (assq 'generation-after load-fields)) :value)))
|
||||
(should (plist-get (plist-get scroll :current-facts)
|
||||
:region-id-present))
|
||||
(should (> (plist-get (plist-get scroll :current-facts) :offset-after)
|
||||
(plist-get (plist-get scroll :current-facts)
|
||||
:offset-before))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-baseline-stable-projections-are-reproducible ()
|
||||
"Reproduce stable semantic/text/identity/SQLite projections twice."
|
||||
(etaf-playground-m0a-test--with-baseline first
|
||||
(etaf-playground-m0a-test--with-baseline second
|
||||
(dolist (key '(:semantic :text-properties :identity :lifecycle :sqlite))
|
||||
(should (equal (plist-get first key) (plist-get second key)))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-batch-writes-semantic-evidence-summary ()
|
||||
"Persist raw package-local evidence plus a machine-readable summary."
|
||||
(let* ((directory (make-temp-file "m0a-semantic-output-" t))
|
||||
(output (expand-file-name "semantic.eld" directory))
|
||||
(metadata (expand-file-name "semantic.json" directory))
|
||||
(process-environment (copy-sequence process-environment)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setenv "ETAF_M0A_SEMANTIC_OUTPUT" output)
|
||||
(setenv "ETAF_M0A_SEMANTIC_METADATA" metadata)
|
||||
(should (etaf-playground-m0a-capture-baseline-batch))
|
||||
(should (> (file-attribute-size (file-attributes output)) 0))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents metadata)
|
||||
(let ((record
|
||||
(json-parse-buffer :object-type 'plist
|
||||
:array-type 'list)))
|
||||
(should (= 6 (plist-get record :scenario_count)))
|
||||
(should (= 1 (plist-get record :schema_version)))
|
||||
(should (eq t (plist-get record
|
||||
:required_work_fields_observed))))))
|
||||
(delete-directory directory t))))
|
||||
|
||||
(provide 'research-shelf-m0a-evidence-tests)
|
||||
;;; research-shelf-m0a-evidence-tests.el ends here
|
||||
Loading…
Reference in New Issue
Block a user