871 lines
39 KiB
EmacsLisp
871 lines
39 KiB
EmacsLisp
;;; 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
|