181 lines
7.8 KiB
EmacsLisp
181 lines
7.8 KiB
EmacsLisp
;;; etaf-playground.el --- Generic ETAF pair playground framework -*- lexical-binding: t; -*-
|
|
|
|
;;; Commentary:
|
|
;; The Playground owns only pair registration, inert `.etaf' validation,
|
|
;; companion loading, mounting, and cleanup. Applications belong in their
|
|
;; same-basename companion modules and never leak into this framework.
|
|
|
|
;;; Code:
|
|
(require 'cl-lib)
|
|
(require 'etaf)
|
|
(require 'etaf-playground-catalog)
|
|
|
|
;; `read' consults this dynamically scoped safety switch. Declare it here
|
|
;; so the lexical-binding compiler does not mistake the protected binding for
|
|
;; an unused lexical local.
|
|
(defvar read-eval)
|
|
|
|
(defconst etaf-playground-buffer-name "*ETAF Playground*"
|
|
"Default buffer used by the generic Playground launcher.")
|
|
(defconst etaf-playground-example-directory
|
|
(expand-file-name "examples"
|
|
(file-name-directory (or load-file-name buffer-file-name)))
|
|
"Directory containing same-basename `.etaf' and `.el' pairs.")
|
|
(defvar etaf-playground-default-pair
|
|
(plist-get (car etaf-playground-catalog) :pair)
|
|
"Pair opened by `etaf-playground-open'.")
|
|
(defvar etaf-playground-scenario-manifest
|
|
(copy-tree etaf-playground-catalog)
|
|
"Registered Playground pair specifications.
|
|
|
|
Each entry declares the pair name, companion feature, root factory, inert
|
|
static tags, public refs, and review metadata. The framework does not inspect
|
|
or special-case the application's business model.")
|
|
(defvar etaf-playground-example-names
|
|
(mapcar (lambda (entry) (plist-get entry :pair))
|
|
etaf-playground-scenario-manifest)
|
|
"Names of registered Playground pairs.")
|
|
(defvar-local etaf-playground-current-example nil)
|
|
|
|
(defun etaf-playground-register-pair (entry)
|
|
"Register or replace a generic Playground pair ENTRY.
|
|
|
|
ENTRY must contain a string `:pair', symbol `:root-component', symbol
|
|
`:companion-feature', and a proper-list `:static-tags'."
|
|
(let ((name (plist-get entry :pair)))
|
|
(unless (and (stringp name) (symbolp (plist-get entry :root-component))
|
|
(symbolp (plist-get entry :companion-feature))
|
|
(proper-list-p (plist-get entry :static-tags)))
|
|
(error "Invalid Playground pair manifest entry: %S" entry))
|
|
(setq etaf-playground-scenario-manifest
|
|
(cons entry
|
|
(cl-remove name etaf-playground-scenario-manifest
|
|
:key (lambda (item) (plist-get item :pair))
|
|
:test #'equal)))
|
|
(setq etaf-playground-example-names
|
|
(mapcar (lambda (item) (plist-get item :pair))
|
|
etaf-playground-scenario-manifest))
|
|
entry))
|
|
|
|
(defun etaf-playground-scenario (name)
|
|
"Return the registered pair specification named NAME."
|
|
(or (cl-find name etaf-playground-scenario-manifest
|
|
:key (lambda (entry) (plist-get entry :pair))
|
|
:test #'equal)
|
|
(user-error "Unknown ETAF Playground pair: %s" name)))
|
|
|
|
(defun etaf-playground--pair-file (name suffix)
|
|
"Return NAME pair path ending in SUFFIX."
|
|
(expand-file-name (concat name suffix) etaf-playground-example-directory))
|
|
|
|
(defun etaf-playground--validate-static-node (node tags)
|
|
"Validate inert static View NODE against allowlisted TAGS."
|
|
(cond
|
|
((or (null node) (stringp node) (numberp node) (keywordp node)
|
|
(memq node '(t stretch viewport-height))) node)
|
|
;; Symbols in a static pair are inert enum/data values. They are not
|
|
;; evaluated because only proper-list nodes become View forms; reject
|
|
;; private runtime names while keeping the manifest format composable.
|
|
((symbolp node)
|
|
(unless (or (string-prefix-p "etaf--" (symbol-name node))
|
|
(string-prefix-p "ebox--" (symbol-name node)))
|
|
node))
|
|
((consp node)
|
|
(unless (and (proper-list-p node) (symbolp (car node))
|
|
(memq (car node) tags)
|
|
(not (string-prefix-p "etaf--" (symbol-name (car node))))
|
|
(not (string-prefix-p "ebox--" (symbol-name (car node)))))
|
|
(error "Unsafe ETAF static View form: %S" node))
|
|
(mapc (lambda (child) (etaf-playground--validate-static-node child tags))
|
|
(cdr node))
|
|
node)
|
|
(t (error "Unsafe ETAF static View value: %S" node))))
|
|
|
|
(defun etaf-playground-read-static (name)
|
|
"Read and validate NAME's single inert `.etaf' form."
|
|
(let ((scenario (etaf-playground-scenario name)))
|
|
(with-temp-buffer
|
|
(insert-file-contents (etaf-playground--pair-file name ".etaf"))
|
|
(let ((read-eval nil))
|
|
(ignore read-eval)
|
|
(let ((form (read (current-buffer))))
|
|
(condition-case nil
|
|
(progn (read (current-buffer))
|
|
(error "ETAF static file contains multiple forms"))
|
|
(end-of-file nil))
|
|
(etaf-playground--validate-static-node
|
|
form (plist-get scenario :static-tags)))))))
|
|
|
|
(defun etaf-playground-read-pair (name)
|
|
"Read NAME data, load its companion, and return its root View."
|
|
(let* ((scenario (etaf-playground-scenario name))
|
|
(form (etaf-playground-read-static name))
|
|
(feature (plist-get scenario :companion-feature))
|
|
(root (plist-get scenario :root-component)))
|
|
(unless (featurep feature)
|
|
(load (file-name-sans-extension
|
|
(etaf-playground--pair-file name ".el")) nil nil nil))
|
|
(unless (functionp root) (error "Missing root factory: %S" root))
|
|
(funcall root form)))
|
|
|
|
(defun etaf-playground-mount-example (buffer-name name)
|
|
"Mount registered pair NAME in BUFFER-NAME."
|
|
(when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
|
(etaf-unmount runtime))
|
|
(let ((buffer (etaf-mount buffer-name (etaf-playground-read-pair name))))
|
|
(with-current-buffer buffer (setq etaf-playground-current-example name))
|
|
buffer))
|
|
|
|
(defun etaf-playground--mount-for-display (buffer-name name)
|
|
"Display BUFFER-NAME before mounting pair NAME when running in a GUI.
|
|
|
|
Ebox resolves viewport-relative widths from the window that owns the target
|
|
buffer. Mounting first would make an off-window daemon/terminal window the
|
|
initial containing block, leaving a responsive pair permanently laid out at
|
|
that stale width until a later explicit resize."
|
|
(unless noninteractive
|
|
;; Keep the current window as the containing block. `pop-to-buffer' may
|
|
;; split a clean frame, cutting a responsive three-column app in half.
|
|
(switch-to-buffer (get-buffer-create buffer-name)))
|
|
(etaf-playground-mount-example buffer-name name))
|
|
|
|
;;;###autoload
|
|
(defun etaf-playground-open (&optional buffer-name)
|
|
"Open the registered default pair in BUFFER-NAME."
|
|
(interactive)
|
|
(etaf-playground--mount-for-display
|
|
(or buffer-name etaf-playground-buffer-name)
|
|
etaf-playground-default-pair))
|
|
|
|
;;;###autoload
|
|
(defun etaf-playground-open-example (name &optional buffer-name)
|
|
"Open registered pair NAME in BUFFER-NAME."
|
|
(interactive (list (completing-read "Pair: " etaf-playground-example-names)))
|
|
(etaf-playground--mount-for-display
|
|
(or buffer-name etaf-playground-buffer-name) name))
|
|
|
|
;;;###autoload
|
|
(defun etaf-playground-reset (&optional buffer-name)
|
|
"Remount the current/default registered pair in BUFFER-NAME."
|
|
(let* ((name (or buffer-name etaf-playground-buffer-name))
|
|
(buffer (get-buffer name))
|
|
(pair (or (and buffer
|
|
(buffer-local-value 'etaf-playground-current-example
|
|
buffer))
|
|
etaf-playground-default-pair)))
|
|
(unless buffer (user-error "No ETAF Playground pair is mounted"))
|
|
(etaf-playground--mount-for-display name pair)))
|
|
|
|
;;;###autoload
|
|
(defun etaf-playground-close (&optional buffer-name)
|
|
"Unmount and kill the Playground BUFFER-NAME."
|
|
(let* ((name (or buffer-name etaf-playground-buffer-name))
|
|
(buffer (get-buffer name)))
|
|
(when-let ((runtime (and buffer (etaf-runtime-for-buffer buffer))))
|
|
(etaf-unmount runtime))
|
|
(when (buffer-live-p buffer) (kill-buffer buffer))
|
|
buffer))
|
|
|
|
(provide 'etaf-playground)
|
|
;;; etaf-playground.el ends here
|