diff --git a/shared/sx/ref/bootstrap_py.py b/shared/sx/ref/bootstrap_py.py index 2116cd3..af42b0a 100644 --- a/shared/sx/ref/bootstrap_py.py +++ b/shared/sx/ref/bootstrap_py.py @@ -1325,9 +1325,17 @@ except ImportError: ) -def _parse_special_forms_spec(ref_dir: str) -> set[str]: +def _parse_special_forms_spec(ref_dir: str, source_dirs=None) -> set[str]: """Parse special-forms.sx to extract declared form names.""" - filepath = os.path.join(ref_dir, "special-forms.sx") + filepath = None + if source_dirs: + for d in source_dirs: + p = os.path.join(d, "special-forms.sx") + if os.path.exists(p): + filepath = p + break + if not filepath: + filepath = os.path.join(ref_dir, "special-forms.sx") if not os.path.exists(filepath): return set() with open(filepath) as f: @@ -1359,9 +1367,9 @@ def _extract_eval_dispatch_names(all_sections: list) -> set[str]: def _validate_special_forms(ref_dir: str, all_sections: list, - has_continuations: bool) -> None: + has_continuations: bool, source_dirs=None) -> None: """Cross-check special-forms.sx against eval.sx dispatch. Warn on mismatches.""" - spec_names = _parse_special_forms_spec(ref_dir) + spec_names = _parse_special_forms_spec(ref_dir, source_dirs=source_dirs) if not spec_names: return @@ -1432,6 +1440,20 @@ def compile_ref_to_py( prim_modules.append(m) ref_dir = os.path.dirname(os.path.abspath(__file__)) + _project = os.path.abspath(os.path.join(ref_dir, "..", "..", "..")) + _source_dirs = [ + os.path.join(_project, "spec"), + os.path.join(_project, "web"), + ref_dir, + ] + + def _find_sx(filename): + for d in _source_dirs: + p = os.path.join(d, filename) + if os.path.exists(p): + return p + return None + emitter = PyEmitter() # Resolve adapter set @@ -1494,7 +1516,7 @@ def compile_ref_to_py( has_async = "async" in adapter_set if has_async: async_filename = ADAPTER_FILES["async"][0] - async_filepath = os.path.join(ref_dir, async_filename) + async_filepath = _find_sx(async_filename) or os.path.join(ref_dir, async_filename) if os.path.exists(async_filepath): with open(async_filepath) as f: async_src = f.read() @@ -1513,7 +1535,7 @@ def compile_ref_to_py( all_sections = [] for filename, label in sx_files: - filepath = os.path.join(ref_dir, filename) + filepath = _find_sx(filename) or os.path.join(ref_dir, filename) if not os.path.exists(filepath): continue with open(filepath) as f: @@ -1531,7 +1553,7 @@ def compile_ref_to_py( has_continuations = "continuations" in ext_set # Validate special forms - _validate_special_forms(ref_dir, all_sections, has_continuations) + _validate_special_forms(ref_dir, all_sections, has_continuations, source_dirs=_source_dirs) # Build output has_html = "html" in adapter_set diff --git a/shared/sx/ref/run_js_sx.py b/shared/sx/ref/run_js_sx.py index 2dfe0b4..096e92a 100644 --- a/shared/sx/ref/run_js_sx.py +++ b/shared/sx/ref/run_js_sx.py @@ -78,6 +78,13 @@ def compile_ref_to_js( from shared.sx.ref.sx_ref import evaluate ref_dir = _HERE + _PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", "..")) + # Source directories: core spec, web framework, and legacy ref (for bootstrapper tools) + _source_dirs = [ + os.path.join(_PROJECT, "spec"), # Core spec + os.path.join(_PROJECT, "web"), # Web framework + ref_dir, # Legacy location (fallback) + ] env = load_js_sx() # Resolve adapter set @@ -195,9 +202,16 @@ def compile_ref_to_js( parts.append(PLATFORM_CEK_JS) # Translate each spec file using js.sx + def _find_sx(filename): + for d in _source_dirs: + p = os.path.join(d, filename) + if os.path.exists(p): + return p + return None + for filename, label in sx_files: - filepath = os.path.join(ref_dir, filename) - if not os.path.exists(filepath): + filepath = _find_sx(filename) + if not filepath: continue with open(filepath) as f: src = f.read() diff --git a/spec/boundary-core.sx b/spec/boundary-core.sx new file mode 100644 index 0000000..9f652d9 --- /dev/null +++ b/spec/boundary-core.sx @@ -0,0 +1,49 @@ +;; ========================================================================== +;; boundary.sx — SX language boundary contract +;; +;; Declares the core I/O primitives that any SX host must provide. +;; This is the LANGUAGE contract — not deployment-specific. +;; +;; Pure primitives (Tier 1) are declared in primitives.sx. +;; Deployment-specific I/O lives in boundary-app.sx. +;; Per-service page helpers live in {service}/sx/boundary.sx. +;; +;; Format: +;; (define-io-primitive "name" +;; :params (param1 param2 &key ...) +;; :returns "type" +;; :effects [io] +;; :async true +;; :doc "description" +;; :context :request) +;; +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; Tier 1: Pure primitives — declared in primitives.sx +;; -------------------------------------------------------------------------- + +(declare-tier :pure :source "primitives.sx") + + +;; -------------------------------------------------------------------------- +;; Core platform primitives — type inspection + environment +;; -------------------------------------------------------------------------- +;; +;; These are provided by every host. Not IO, not web-specific. + +(declare-core-primitive "type-of" + :params (value) + :returns "string" + :doc "Return the type name of a value.") + +(declare-core-primitive "make-env" + :params () + :returns "dict" + :doc "Create a base environment with all primitives.") + +(declare-core-primitive "identical?" + :params (a b) + :returns "boolean" + :doc "Reference equality check.") diff --git a/spec/callcc.sx b/spec/callcc.sx new file mode 100644 index 0000000..6fe6716 --- /dev/null +++ b/spec/callcc.sx @@ -0,0 +1,245 @@ +;; ========================================================================== +;; callcc.sx — Full first-class continuations (call/cc) +;; +;; OPTIONAL EXTENSION — not required by the core evaluator. +;; Bootstrappers include this only when the target supports it naturally. +;; +;; Full call/cc (call-with-current-continuation) captures the ENTIRE +;; remaining computation as a first-class function — not just up to a +;; delimiter, but all the way to the top level. Invoking a continuation +;; captured by call/cc abandons the current computation entirely and +;; resumes from where the continuation was captured. +;; +;; This is strictly more powerful than delimited continuations (shift/reset) +;; but harder to implement in targets that don't support it natively. +;; Recommended only for targets where it's natural: +;; - Scheme/Racket (native call/cc) +;; - Haskell (ContT monad transformer) +;; +;; For targets like Python, JavaScript, and Rust, delimited continuations +;; (continuations.sx) are more practical and cover the same use cases +;; without requiring a global CPS transform. +;; +;; One new special form: +;; (call/cc f) — call f with the current continuation +;; +;; One new type: +;; continuation — same type as in continuations.sx +;; +;; If both extensions are loaded, the continuation type is shared. +;; Delimited and undelimited continuations are the same type — +;; the difference is in how they are captured, not what they are. +;; +;; Platform requirements: +;; (make-continuation fn) — wrap a function as a continuation value +;; (continuation? x) — type predicate +;; (type-of continuation) → "continuation" +;; (call-with-cc f env) — target-specific call/cc implementation +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. Semantics +;; -------------------------------------------------------------------------- +;; +;; (call/cc f) +;; +;; Evaluates f (which must be a function of one argument), passing it the +;; current continuation as a continuation value. f can: +;; +;; a) Return normally — call/cc returns whatever f returns +;; b) Invoke the continuation — abandons f's computation, call/cc +;; "returns" the value passed to the continuation +;; c) Store the continuation — invoke it later, possibly multiple times +;; +;; Key difference from shift/reset: invoking an undelimited continuation +;; NEVER RETURNS to the caller. It abandons the current computation and +;; jumps back to where call/cc was originally called. +;; +;; ;; Delimited (shift/reset) — k returns a value: +;; (reset (+ 1 (shift k (+ (k 10) (k 20))))) +;; ;; (k 10) → 11, returns to the (+ ... (k 20)) expression +;; ;; (k 20) → 21, returns to the (+ 11 ...) expression +;; ;; result: 32 +;; +;; ;; Undelimited (call/cc) — k does NOT return: +;; (+ 1 (call/cc (fn (k) +;; (+ (k 10) (k 20))))) +;; ;; (k 10) abandons (+ (k 10) (k 20)) entirely +;; ;; jumps back to (+ 1 _) with 10 +;; ;; result: 11 +;; ;; (k 20) is never reached +;; +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 2. call/cc — call with current continuation +;; -------------------------------------------------------------------------- + +(define sf-callcc + (fn (args env) + ;; Single argument: a function to call with the current continuation. + (let ((f-expr (first args)) + (f (trampoline (eval-expr f-expr env)))) + (call-with-cc f env)))) + + +;; -------------------------------------------------------------------------- +;; 3. Derived forms +;; -------------------------------------------------------------------------- +;; +;; With call/cc available, several patterns become expressible: +;; +;; --- Early return --- +;; +;; (define find-first +;; (fn (pred items) +;; (call/cc (fn (return) +;; (for-each (fn (item) +;; (when (pred item) +;; (return item))) +;; items) +;; nil)))) +;; +;; --- Exception-like flow --- +;; +;; (define try-catch +;; (fn (body handler) +;; (call/cc (fn (throw) +;; (body throw))))) +;; +;; (try-catch +;; (fn (throw) +;; (let ((result (dangerous-operation))) +;; (when (not result) (throw "failed")) +;; result)) +;; (fn (error) (str "Caught: " error))) +;; +;; --- Coroutines --- +;; +;; Two call/cc captures that alternate control between two +;; computations. Each captures its own continuation, then invokes +;; the other's. This gives cooperative multitasking without threads. +;; +;; --- Undo --- +;; +;; (define with-undo +;; (fn (action) +;; (call/cc (fn (restore) +;; (action) +;; restore)))) +;; +;; ;; (let ((undo (with-undo (fn () (delete-item 42))))) +;; ;; (undo "anything")) → item 42 is back +;; +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 4. Interaction with delimited continuations +;; -------------------------------------------------------------------------- +;; +;; If both callcc.sx and continuations.sx are loaded: +;; +;; - The continuation type is shared. (continuation? k) returns true +;; for both delimited and undelimited continuations. +;; +;; - shift inside a call/cc body captures up to the nearest reset, +;; not up to the call/cc. The two mechanisms compose. +;; +;; - call/cc inside a reset body captures the entire continuation +;; (past the reset). This is the expected behavior — call/cc is +;; undelimited by definition. +;; +;; - A delimited continuation (from shift) returns a value when invoked. +;; An undelimited continuation (from call/cc) does not return. +;; Both are callable with the same syntax: (k value). +;; The caller cannot distinguish them by type — only by behavior. +;; +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 5. Interaction with I/O and state +;; -------------------------------------------------------------------------- +;; +;; Full call/cc has well-known interactions with side effects: +;; +;; Re-entry: +;; Invoking a saved continuation re-enters a completed computation. +;; If that computation mutated state (set!, I/O writes), the mutations +;; are NOT undone. The continuation resumes in the current state, +;; not the state at the time of capture. +;; +;; I/O: +;; Same as delimited continuations — I/O executes at invocation time. +;; A continuation containing (current-user) will call current-user +;; when invoked, in whatever request context exists then. +;; +;; Dynamic extent: +;; call/cc captures the continuation, not the dynamic environment. +;; Host-language context (Python's Quart request context, JavaScript's +;; async context) may not be valid when a saved continuation is invoked +;; later. Typed targets can enforce this; dynamic targets fail at runtime. +;; +;; Recommendation: +;; Use call/cc for pure control flow (early return, coroutines, +;; backtracking). Use delimited continuations for effectful patterns +;; (suspense, cooperative scheduling) where the delimiter provides +;; a natural boundary. +;; +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 6. Implementation notes per target +;; -------------------------------------------------------------------------- +;; +;; Scheme / Racket: +;; Native call/cc. Zero implementation effort. +;; +;; Haskell: +;; ContT monad transformer. The evaluator runs in ContT, and call/cc +;; is callCC from Control.Monad.Cont. Natural and type-safe. +;; +;; Python: +;; Requires full CPS transform of the evaluator, or greenlet-based +;; stack capture. Significantly more invasive than delimited +;; continuations. NOT RECOMMENDED — use continuations.sx instead. +;; +;; JavaScript: +;; Requires full CPS transform. Cannot be implemented with generators +;; alone (generators only support delimited yield, not full escape). +;; NOT RECOMMENDED — use continuations.sx instead. +;; +;; Rust: +;; Full CPS transform at compile time. Possible but adds significant +;; complexity. Delimited continuations are more natural (enum-based). +;; Consider only if the target genuinely needs undelimited escape. +;; +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 7. Platform interface — what each target must provide +;; -------------------------------------------------------------------------- +;; +;; (call-with-cc f env) +;; Call f with the current continuation. f is a function of one +;; argument (the continuation). If f returns normally, call-with-cc +;; returns f's result. If f invokes the continuation, the computation +;; jumps to the call-with-cc call site with the provided value. +;; +;; (make-continuation fn) +;; Wrap a native function as a continuation value. +;; (Shared with continuations.sx if both are loaded.) +;; +;; (continuation? x) +;; Type predicate. +;; (Shared with continuations.sx if both are loaded.) +;; +;; Continuations must be callable via the standard function-call +;; dispatch in eval-list (same path as lambda calls). +;; +;; -------------------------------------------------------------------------- diff --git a/spec/cek.sx b/spec/cek.sx new file mode 100644 index 0000000..b93437f --- /dev/null +++ b/spec/cek.sx @@ -0,0 +1,1178 @@ +;; ========================================================================== +;; cek.sx — Explicit CEK machine evaluator +;; +;; Replaces the implicit CEK (tree-walk + trampoline) with explicit +;; C/E/K data structures. Each evaluation step is a pure function from +;; state to state. Enables stepping, serialization, migration. +;; +;; The CEK uses the frame types defined in frames.sx. +;; eval-expr remains as the public API — it creates a CEK state and runs. +;; +;; Requires: frames.sx loaded first. +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. Run loop — drive the CEK machine to completion +;; -------------------------------------------------------------------------- + +(define cek-run + (fn (state) + ;; Drive the CEK machine until terminal state. + ;; Returns the final value. + (if (cek-terminal? state) + (cek-value state) + (cek-run (cek-step state))))) + + +;; -------------------------------------------------------------------------- +;; 2. Step function — single CEK step +;; -------------------------------------------------------------------------- + +(define cek-step + (fn (state) + (if (= (cek-phase state) "eval") + (step-eval state) + (step-continue state)))) + + +;; -------------------------------------------------------------------------- +;; 3. step-eval — Control is an expression, dispatch on type +;; -------------------------------------------------------------------------- + +(define step-eval + (fn (state) + (let ((expr (cek-control state)) + (env (cek-env state)) + (kont (cek-kont state))) + (case (type-of expr) + + ;; --- Literals: immediate value --- + "number" (make-cek-value expr env kont) + "string" (make-cek-value expr env kont) + "boolean" (make-cek-value expr env kont) + "nil" (make-cek-value nil env kont) + + ;; --- Symbol lookup --- + "symbol" + (let ((name (symbol-name expr))) + (let ((val (cond + (env-has? env name) (env-get env name) + (primitive? name) (get-primitive name) + (= name "true") true + (= name "false") false + (= name "nil") nil + :else (error (str "Undefined symbol: " name))))) + (make-cek-value val env kont))) + + ;; --- Keyword → string --- + "keyword" (make-cek-value (keyword-name expr) env kont) + + ;; --- Dict literal: evaluate values --- + "dict" + (let ((ks (keys expr))) + (if (empty? ks) + (make-cek-value (dict) env kont) + ;; Build entry pairs from dict, evaluate first value + (let ((first-key (first ks)) + (remaining-entries (list))) + (for-each (fn (k) (append! remaining-entries (list k (get expr k)))) + (rest ks)) + (make-cek-state + (get expr first-key) + env + (kont-push + (make-dict-frame + remaining-entries + (list (list first-key)) ;; results: list of (key) waiting for val + env) + kont))))) + + ;; --- List = call or special form --- + "list" + (if (empty? expr) + (make-cek-value (list) env kont) + (step-eval-list expr env kont)) + + ;; --- Anything else passes through --- + :else (make-cek-value expr env kont))))) + + +;; -------------------------------------------------------------------------- +;; 4. step-eval-list — Dispatch on list head +;; -------------------------------------------------------------------------- + +(define step-eval-list + (fn (expr env kont) + (let ((head (first expr)) + (args (rest expr))) + + ;; If head isn't symbol/lambda/list → treat as data list + (if (not (or (= (type-of head) "symbol") + (= (type-of head) "lambda") + (= (type-of head) "list"))) + ;; Evaluate as data list — evaluate each element + (if (empty? expr) + (make-cek-value (list) env kont) + (make-cek-state + (first expr) env + (kont-push (make-map-frame nil (rest expr) (list) env) kont))) + + ;; Head is symbol — check special forms + (if (= (type-of head) "symbol") + (let ((name (symbol-name head))) + (cond + ;; --- Special forms → push appropriate frame --- + (= name "if") (step-sf-if args env kont) + (= name "when") (step-sf-when args env kont) + (= name "cond") (step-sf-cond args env kont) + (= name "case") (step-sf-case args env kont) + (= name "and") (step-sf-and args env kont) + (= name "or") (step-sf-or args env kont) + (= name "let") (step-sf-let args env kont) + (= name "let*") (step-sf-let args env kont) + (= name "lambda") (step-sf-lambda args env kont) + (= name "fn") (step-sf-lambda args env kont) + (= name "define") (step-sf-define args env kont) + (= name "defcomp") (make-cek-value (sf-defcomp args env) env kont) + (= name "defisland") (make-cek-value (sf-defisland args env) env kont) + (= name "defmacro") (make-cek-value (sf-defmacro args env) env kont) + (= name "defstyle") (make-cek-value (sf-defstyle args env) env kont) + (= name "defhandler") (make-cek-value (sf-defhandler args env) env kont) + (= name "defpage") (make-cek-value (sf-defpage args env) env kont) + (= name "defquery") (make-cek-value (sf-defquery args env) env kont) + (= name "defaction") (make-cek-value (sf-defaction args env) env kont) + (= name "deftype") (make-cek-value (sf-deftype args env) env kont) + (= name "defeffect") (make-cek-value (sf-defeffect args env) env kont) + (= name "begin") (step-sf-begin args env kont) + (= name "do") (step-sf-begin args env kont) + (= name "quote") (make-cek-value (if (empty? args) nil (first args)) env kont) + (= name "quasiquote") (make-cek-value (qq-expand (first args) env) env kont) + (= name "->") (step-sf-thread-first args env kont) + (= name "set!") (step-sf-set! args env kont) + (= name "letrec") (make-cek-value (sf-letrec args env) env kont) + + ;; Continuations — native in CEK + (= name "reset") (step-sf-reset args env kont) + (= name "shift") (step-sf-shift args env kont) + + ;; Reactive deref-as-shift + (= name "deref") (step-sf-deref args env kont) + + ;; Scoped effects + (= name "scope") (step-sf-scope args env kont) + (= name "provide") (step-sf-provide args env kont) + + ;; Dynamic wind + (= name "dynamic-wind") (make-cek-value (sf-dynamic-wind args env) env kont) + + ;; Higher-order forms + (= name "map") (step-ho-map args env kont) + (= name "map-indexed") (step-ho-map-indexed args env kont) + (= name "filter") (step-ho-filter args env kont) + (= name "reduce") (step-ho-reduce args env kont) + (= name "some") (step-ho-some args env kont) + (= name "every?") (step-ho-every args env kont) + (= name "for-each") (step-ho-for-each args env kont) + + ;; Macro expansion + (and (env-has? env name) (macro? (env-get env name))) + (let ((mac (env-get env name))) + (make-cek-state (expand-macro mac args env) env kont)) + + ;; Render expression + (and (render-active?) (is-render-expr? expr)) + (make-cek-value (render-expr expr env) env kont) + + ;; Fall through to function call + :else (step-eval-call head args env kont))) + + ;; Head is lambda or list — function call + (step-eval-call head args env kont)))))) + + +;; -------------------------------------------------------------------------- +;; 5. Special form step handlers +;; -------------------------------------------------------------------------- + +;; if: evaluate condition, push IfFrame +(define step-sf-if + (fn (args env kont) + (make-cek-state + (first args) env + (kont-push + (make-if-frame (nth args 1) + (if (> (len args) 2) (nth args 2) nil) + env) + kont)))) + +;; when: evaluate condition, push WhenFrame +(define step-sf-when + (fn (args env kont) + (make-cek-state + (first args) env + (kont-push (make-when-frame (rest args) env) kont)))) + +;; begin/do: evaluate first expr, push BeginFrame for rest +(define step-sf-begin + (fn (args env kont) + (if (empty? args) + (make-cek-value nil env kont) + (if (= (len args) 1) + (make-cek-state (first args) env kont) + (make-cek-state + (first args) env + (kont-push (make-begin-frame (rest args) env) kont)))))) + +;; let: start evaluating bindings +(define step-sf-let + (fn (args env kont) + ;; Detect named let + (if (= (type-of (first args)) "symbol") + ;; Named let — delegate to existing handler (complex desugaring) + (make-cek-value (sf-named-let args env) env kont) + (let ((bindings (first args)) + (body (rest args)) + (local (env-extend env))) + ;; Parse first binding + (if (empty? bindings) + ;; No bindings — evaluate body + (step-sf-begin body local kont) + ;; Start evaluating first binding value + (let ((first-binding (if (and (= (type-of (first bindings)) "list") + (= (len (first bindings)) 2)) + ;; Scheme-style: ((name val) ...) + (first bindings) + ;; Clojure-style: (name val ...) → synthesize pair + (list (first bindings) (nth bindings 1)))) + (rest-bindings (if (and (= (type-of (first bindings)) "list") + (= (len (first bindings)) 2)) + (rest bindings) + ;; Clojure-style: skip 2 elements + (let ((pairs (list))) + (reduce + (fn (acc i) + (append! pairs (list (nth bindings (* i 2)) + (nth bindings (inc (* i 2)))))) + nil + (range 1 (/ (len bindings) 2))) + pairs)))) + (let ((vname (if (= (type-of (first first-binding)) "symbol") + (symbol-name (first first-binding)) + (first first-binding)))) + (make-cek-state + (nth first-binding 1) local + (kont-push + (make-let-frame vname rest-bindings body local) + kont))))))))) + +;; define: evaluate value expression +(define step-sf-define + (fn (args env kont) + (let ((name-sym (first args)) + (has-effects (and (>= (len args) 4) + (= (type-of (nth args 1)) "keyword") + (= (keyword-name (nth args 1)) "effects"))) + (val-idx (if (and (>= (len args) 4) + (= (type-of (nth args 1)) "keyword") + (= (keyword-name (nth args 1)) "effects")) + 3 1)) + (effect-list (if (and (>= (len args) 4) + (= (type-of (nth args 1)) "keyword") + (= (keyword-name (nth args 1)) "effects")) + (nth args 2) nil))) + (make-cek-state + (nth args val-idx) env + (kont-push + (make-define-frame (symbol-name name-sym) env has-effects effect-list) + kont))))) + +;; set!: evaluate value +(define step-sf-set! + (fn (args env kont) + (make-cek-state + (nth args 1) env + (kont-push (make-set-frame (symbol-name (first args)) env) kont)))) + +;; and: evaluate first, push AndFrame +(define step-sf-and + (fn (args env kont) + (if (empty? args) + (make-cek-value true env kont) + (make-cek-state + (first args) env + (kont-push (make-and-frame (rest args) env) kont))))) + +;; or: evaluate first, push OrFrame +(define step-sf-or + (fn (args env kont) + (if (empty? args) + (make-cek-value false env kont) + (make-cek-state + (first args) env + (kont-push (make-or-frame (rest args) env) kont))))) + +;; cond: evaluate first test, push CondFrame +(define step-sf-cond + (fn (args env kont) + (let ((scheme? (cond-scheme? args))) + (if scheme? + ;; Scheme-style: ((test body) ...) + (if (empty? args) + (make-cek-value nil env kont) + (let ((clause (first args)) + (test (first clause))) + ;; Check for :else / else + (if (or (and (= (type-of test) "symbol") + (or (= (symbol-name test) "else") + (= (symbol-name test) ":else"))) + (and (= (type-of test) "keyword") + (= (keyword-name test) "else"))) + (make-cek-state (nth clause 1) env kont) + (make-cek-state + test env + (kont-push (make-cond-frame args env true) kont))))) + ;; Clojure-style: test body test body ... + (if (< (len args) 2) + (make-cek-value nil env kont) + (let ((test (first args))) + (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) + (and (= (type-of test) "symbol") + (or (= (symbol-name test) "else") + (= (symbol-name test) ":else")))) + (make-cek-state (nth args 1) env kont) + (make-cek-state + test env + (kont-push (make-cond-frame args env false) kont))))))))) + +;; case: evaluate match value +(define step-sf-case + (fn (args env kont) + (make-cek-state + (first args) env + (kont-push (make-case-frame nil (rest args) env) kont)))) + +;; thread-first: evaluate initial value +(define step-sf-thread-first + (fn (args env kont) + (make-cek-state + (first args) env + (kont-push (make-thread-frame (rest args) env) kont)))) + +;; lambda/fn: immediate — create lambda value +(define step-sf-lambda + (fn (args env kont) + (make-cek-value (sf-lambda args env) env kont))) + +;; scope: evaluate name, then push ScopeFrame +(define step-sf-scope + (fn (args env kont) + ;; Delegate to existing sf-scope for now — scope involves mutation + (make-cek-value (sf-scope args env) env kont))) + +;; provide: delegate to existing handler +(define step-sf-provide + (fn (args env kont) + (make-cek-value (sf-provide args env) env kont))) + +;; reset: push ResetFrame, evaluate body +(define step-sf-reset + (fn (args env kont) + (make-cek-state + (first args) env + (kont-push (make-reset-frame env) kont)))) + +;; shift: capture frames to nearest reset +(define step-sf-shift + (fn (args env kont) + (let ((k-name (symbol-name (first args))) + (body (nth args 1)) + (captured-result (kont-capture-to-reset kont)) + (captured (first captured-result)) + (rest-kont (nth captured-result 1))) + ;; Store captured frames as a dict on the continuation value. + ;; When the continuation is invoked, continue-with-call detects + ;; the cek-frames key and restores them. + (let ((k (make-cek-continuation captured rest-kont))) + ;; Evaluate shift body with k bound, continuation goes to rest-kont + (let ((shift-env (env-extend env))) + (env-set! shift-env k-name k) + (make-cek-state body shift-env rest-kont)))))) + + +;; deref: evaluate argument, push DerefFrame +(define step-sf-deref + (fn (args env kont) + (make-cek-state + (first args) env + (kont-push (make-deref-frame env) kont)))) + +;; cek-call — call a function via CEK (replaces invoke) +(define cek-call + (fn (f args) + (let ((a (if (nil? args) (list) args))) + (cond + (nil? f) nil + (lambda? f) (cek-run (continue-with-call f a (dict) a (list))) + (callable? f) (apply f a) + :else nil)))) + +;; reactive-shift-deref: the heart of deref-as-shift +;; When deref encounters a signal inside a reactive-reset boundary, +;; capture the continuation up to the reactive-reset as the subscriber. +(define reactive-shift-deref + (fn (sig env kont) + (let ((scan-result (kont-capture-to-reactive-reset kont)) + (captured-frames (first scan-result)) + (reset-frame (nth scan-result 1)) + (remaining-kont (nth scan-result 2)) + (update-fn (get reset-frame "update-fn"))) + ;; Sub-scope for nested subscriber cleanup on re-invocation + (let ((sub-disposers (list))) + (let ((subscriber + (fn () + ;; Dispose previous nested subscribers + (for-each (fn (d) (cek-call d nil)) sub-disposers) + (set! sub-disposers (list)) + ;; Re-invoke: push fresh ReactiveResetFrame (first-render=false) + (let ((new-reset (make-reactive-reset-frame env update-fn false)) + (new-kont (concat captured-frames + (list new-reset) + remaining-kont))) + (with-island-scope + (fn (d) (append! sub-disposers d)) + (fn () + (cek-run + (make-cek-value (signal-value sig) env new-kont)))))))) + ;; Register subscriber + (signal-add-sub! sig subscriber) + ;; Register cleanup with island scope + (register-in-scope + (fn () + (signal-remove-sub! sig subscriber) + (for-each (fn (d) (cek-call d nil)) sub-disposers))) + ;; Initial render: value flows through captured frames + reset (first-render=true) + ;; so the full expression completes normally + (let ((initial-kont (concat captured-frames + (list reset-frame) + remaining-kont))) + (make-cek-value (signal-value sig) env initial-kont))))))) + + +;; -------------------------------------------------------------------------- +;; 6. Function call step handler +;; -------------------------------------------------------------------------- + +(define step-eval-call + (fn (head args env kont) + ;; First evaluate the head, then evaluate args left-to-right + (make-cek-state + head env + (kont-push + (make-arg-frame nil (list) args env args) + kont)))) + + +;; -------------------------------------------------------------------------- +;; 7. Higher-order form step handlers +;; -------------------------------------------------------------------------- + +;; CEK-native higher-order forms — each callback invocation goes through +;; continue-with-call so deref-as-shift works inside callbacks. +;; Function and collection args are evaluated via tree-walk (simple exprs), +;; then the loop is driven by CEK frames. + +(define step-ho-map + (fn (args env kont) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (if (empty? coll) + (make-cek-value (list) env kont) + (continue-with-call f (list (first coll)) env (list) + (kont-push (make-map-frame f (rest coll) (list) env) kont)))))) + +(define step-ho-map-indexed + (fn (args env kont) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (if (empty? coll) + (make-cek-value (list) env kont) + (continue-with-call f (list 0 (first coll)) env (list) + (kont-push (make-map-indexed-frame f (rest coll) (list) env) kont)))))) + +(define step-ho-filter + (fn (args env kont) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (if (empty? coll) + (make-cek-value (list) env kont) + (continue-with-call f (list (first coll)) env (list) + (kont-push (make-filter-frame f (rest coll) (list) (first coll) env) kont)))))) + +(define step-ho-reduce + (fn (args env kont) + (let ((f (trampoline (eval-expr (first args) env))) + (init (trampoline (eval-expr (nth args 1) env))) + (coll (trampoline (eval-expr (nth args 2) env)))) + (if (empty? coll) + (make-cek-value init env kont) + (continue-with-call f (list init (first coll)) env (list) + (kont-push (make-reduce-frame f (rest coll) env) kont)))))) + +(define step-ho-some + (fn (args env kont) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (if (empty? coll) + (make-cek-value false env kont) + (continue-with-call f (list (first coll)) env (list) + (kont-push (make-some-frame f (rest coll) env) kont)))))) + +(define step-ho-every + (fn (args env kont) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (if (empty? coll) + (make-cek-value true env kont) + (continue-with-call f (list (first coll)) env (list) + (kont-push (make-every-frame f (rest coll) env) kont)))))) + +(define step-ho-for-each + (fn (args env kont) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (if (empty? coll) + (make-cek-value nil env kont) + (continue-with-call f (list (first coll)) env (list) + (kont-push (make-for-each-frame f (rest coll) env) kont)))))) + + +;; -------------------------------------------------------------------------- +;; 8. step-continue — Value produced, dispatch on top frame +;; -------------------------------------------------------------------------- + +(define step-continue + (fn (state) + (let ((value (cek-value state)) + (env (cek-env state)) + (kont (cek-kont state))) + (if (kont-empty? kont) + state ;; Terminal — return as-is + (let ((frame (kont-top kont)) + (rest-k (kont-pop kont)) + (ft (frame-type frame))) + (cond + + ;; --- IfFrame: condition evaluated --- + (= ft "if") + (if (and value (not (nil? value))) + (make-cek-state (get frame "then") (get frame "env") rest-k) + (if (nil? (get frame "else")) + (make-cek-value nil env rest-k) + (make-cek-state (get frame "else") (get frame "env") rest-k))) + + ;; --- WhenFrame: condition evaluated --- + (= ft "when") + (if (and value (not (nil? value))) + (let ((body (get frame "body")) + (fenv (get frame "env"))) + (if (empty? body) + (make-cek-value nil fenv rest-k) + (if (= (len body) 1) + (make-cek-state (first body) fenv rest-k) + (make-cek-state + (first body) fenv + (kont-push (make-begin-frame (rest body) fenv) rest-k))))) + (make-cek-value nil env rest-k)) + + ;; --- BeginFrame: expression evaluated, continue with next --- + (= ft "begin") + (let ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if (empty? remaining) + (make-cek-value value fenv rest-k) + (if (= (len remaining) 1) + (make-cek-state (first remaining) fenv rest-k) + (make-cek-state + (first remaining) fenv + (kont-push (make-begin-frame (rest remaining) fenv) rest-k))))) + + ;; --- LetFrame: binding value evaluated --- + (= ft "let") + (let ((name (get frame "name")) + (remaining (get frame "remaining")) + (body (get frame "body")) + (local (get frame "env"))) + ;; Bind the value + (env-set! local name value) + ;; More bindings? + (if (empty? remaining) + ;; All bindings done — evaluate body + (step-sf-begin body local rest-k) + ;; Next binding + (let ((next-binding (first remaining)) + (vname (if (= (type-of (first next-binding)) "symbol") + (symbol-name (first next-binding)) + (first next-binding)))) + (make-cek-state + (nth next-binding 1) local + (kont-push + (make-let-frame vname (rest remaining) body local) + rest-k))))) + + ;; --- DefineFrame: value evaluated --- + (= ft "define") + (let ((name (get frame "name")) + (fenv (get frame "env")) + (has-effects (get frame "has-effects")) + (effect-list (get frame "effect-list"))) + (when (and (lambda? value) (nil? (lambda-name value))) + (set-lambda-name! value name)) + (env-set! fenv name value) + ;; Effect annotation + (when has-effects + (let ((effect-names (if (= (type-of effect-list) "list") + (map (fn (e) (if (= (type-of e) "symbol") + (symbol-name e) (str e))) + effect-list) + (list (str effect-list)))) + (effect-anns (if (env-has? fenv "*effect-annotations*") + (env-get fenv "*effect-annotations*") + (dict)))) + (dict-set! effect-anns name effect-names) + (env-set! fenv "*effect-annotations*" effect-anns))) + (make-cek-value value fenv rest-k)) + + ;; --- SetFrame: value evaluated --- + (= ft "set") + (let ((name (get frame "name")) + (fenv (get frame "env"))) + (env-set! fenv name value) + (make-cek-value value env rest-k)) + + ;; --- AndFrame: value evaluated --- + (= ft "and") + (if (not value) + (make-cek-value value env rest-k) + (let ((remaining (get frame "remaining"))) + (if (empty? remaining) + (make-cek-value value env rest-k) + (make-cek-state + (first remaining) (get frame "env") + (if (= (len remaining) 1) + rest-k + (kont-push (make-and-frame (rest remaining) (get frame "env")) rest-k)))))) + + ;; --- OrFrame: value evaluated --- + (= ft "or") + (if value + (make-cek-value value env rest-k) + (let ((remaining (get frame "remaining"))) + (if (empty? remaining) + (make-cek-value false env rest-k) + (make-cek-state + (first remaining) (get frame "env") + (if (= (len remaining) 1) + rest-k + (kont-push (make-or-frame (rest remaining) (get frame "env")) rest-k)))))) + + ;; --- CondFrame: test evaluated --- + (= ft "cond") + (let ((remaining (get frame "remaining")) + (fenv (get frame "env")) + (scheme? (get frame "scheme"))) + (if scheme? + ;; Scheme-style: test truthy → evaluate body + (if value + (make-cek-state (nth (first remaining) 1) fenv rest-k) + ;; Next clause + (let ((next-clauses (rest remaining))) + (if (empty? next-clauses) + (make-cek-value nil fenv rest-k) + (let ((next-clause (first next-clauses)) + (next-test (first next-clause))) + (if (or (and (= (type-of next-test) "symbol") + (or (= (symbol-name next-test) "else") + (= (symbol-name next-test) ":else"))) + (and (= (type-of next-test) "keyword") + (= (keyword-name next-test) "else"))) + (make-cek-state (nth next-clause 1) fenv rest-k) + (make-cek-state + next-test fenv + (kont-push (make-cond-frame next-clauses fenv true) rest-k))))))) + ;; Clojure-style + (if value + (make-cek-state (nth remaining 1) fenv rest-k) + (let ((next (slice remaining 2))) + (if (< (len next) 2) + (make-cek-value nil fenv rest-k) + (let ((next-test (first next))) + (if (or (and (= (type-of next-test) "keyword") (= (keyword-name next-test) "else")) + (and (= (type-of next-test) "symbol") + (or (= (symbol-name next-test) "else") + (= (symbol-name next-test) ":else")))) + (make-cek-state (nth next 1) fenv rest-k) + (make-cek-state + next-test fenv + (kont-push (make-cond-frame next fenv false) rest-k))))))))) + + ;; --- CaseFrame --- + (= ft "case") + (let ((match-val (get frame "match-val")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if (nil? match-val) + ;; First step: match-val just evaluated + (sf-case-step-loop value remaining fenv rest-k) + ;; Subsequent: test clause evaluated + (sf-case-step-loop match-val remaining fenv rest-k))) + + ;; --- ThreadFirstFrame --- + (= ft "thread") + (let ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if (empty? remaining) + (make-cek-value value fenv rest-k) + ;; Apply next form to value + (let ((form (first remaining)) + (rest-forms (rest remaining))) + (let ((result (if (= (type-of form) "list") + (let ((f (trampoline (eval-expr (first form) fenv))) + (rargs (map (fn (a) (trampoline (eval-expr a fenv))) (rest form))) + (all-args (cons value rargs))) + (cond + (and (callable? f) (not (lambda? f))) (apply f all-args) + (lambda? f) (trampoline (call-lambda f all-args fenv)) + :else (error (str "-> form not callable: " (inspect f))))) + (let ((f (trampoline (eval-expr form fenv)))) + (cond + (and (callable? f) (not (lambda? f))) (f value) + (lambda? f) (trampoline (call-lambda f (list value) fenv)) + :else (error (str "-> form not callable: " (inspect f)))))))) + (if (empty? rest-forms) + (make-cek-value result fenv rest-k) + (make-cek-value result fenv + (kont-push (make-thread-frame rest-forms fenv) rest-k))))))) + + ;; --- ArgFrame: head or arg evaluated --- + (= ft "arg") + (let ((f (get frame "f")) + (evaled (get frame "evaled")) + (remaining (get frame "remaining")) + (fenv (get frame "env")) + (raw-args (get frame "raw-args"))) + (if (nil? f) + ;; Head just evaluated — value is the function + (if (empty? remaining) + ;; No args — call immediately + (continue-with-call value (list) fenv raw-args rest-k) + ;; Start evaluating args + (make-cek-state + (first remaining) fenv + (kont-push + (make-arg-frame value (list) (rest remaining) fenv raw-args) + rest-k))) + ;; An arg was evaluated — accumulate + (let ((new-evaled (append evaled (list value)))) + (if (empty? remaining) + ;; All args evaluated — call + (continue-with-call f new-evaled fenv raw-args rest-k) + ;; Next arg + (make-cek-state + (first remaining) fenv + (kont-push + (make-arg-frame f new-evaled (rest remaining) fenv raw-args) + rest-k)))))) + + ;; --- DictFrame: value evaluated --- + (= ft "dict") + (let ((remaining (get frame "remaining")) + (results (get frame "results")) + (fenv (get frame "env"))) + ;; Last result entry is (key) — append value to make (key val) + (let ((last-result (last results)) + (completed (append (slice results 0 (dec (len results))) + (list (list (first last-result) value))))) + (if (empty? remaining) + ;; All done — build dict + (let ((d (dict))) + (for-each + (fn (pair) (dict-set! d (first pair) (nth pair 1))) + completed) + (make-cek-value d fenv rest-k)) + ;; Next entry + (let ((next-entry (first remaining))) + (make-cek-state + (nth next-entry 1) fenv + (kont-push + (make-dict-frame + (rest remaining) + (append completed (list (list (first next-entry)))) + fenv) + rest-k)))))) + + ;; --- ResetFrame: body evaluated normally (no shift) --- + (= ft "reset") + (make-cek-value value env rest-k) + + ;; --- DerefFrame: deref argument evaluated --- + (= ft "deref") + (let ((val value) + (fenv (get frame "env"))) + (if (not (signal? val)) + ;; Not a signal: pass through + (make-cek-value val fenv rest-k) + ;; Signal: check for ReactiveResetFrame + (if (has-reactive-reset-frame? rest-k) + ;; Perform reactive shift + (reactive-shift-deref val fenv rest-k) + ;; No reactive-reset: normal deref (scope-based tracking) + (do + (let ((ctx (context "sx-reactive" nil))) + (when ctx + (let ((dep-list (get ctx "deps")) + (notify-fn (get ctx "notify"))) + (when (not (contains? dep-list val)) + (append! dep-list val) + (signal-add-sub! val notify-fn))))) + (make-cek-value (signal-value val) fenv rest-k))))) + + ;; --- ReactiveResetFrame: expression completed --- + (= ft "reactive-reset") + (let ((update-fn (get frame "update-fn")) + (first? (get frame "first-render"))) + ;; On re-render (not first), call update-fn with new value + (when (and update-fn (not first?)) + (cek-call update-fn (list value))) + (make-cek-value value env rest-k)) + + ;; --- ScopeFrame: body result --- + (= ft "scope") + (let ((name (get frame "name")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if (empty? remaining) + (do (scope-pop! name) + (make-cek-value value fenv rest-k)) + (make-cek-state + (first remaining) fenv + (kont-push + (make-scope-frame name (rest remaining) fenv) + rest-k)))) + + ;; --- MapFrame: callback result for map/map-indexed --- + (= ft "map") + (let ((f (get frame "f")) + (remaining (get frame "remaining")) + (results (get frame "results")) + (indexed (get frame "indexed")) + (fenv (get frame "env"))) + (let ((new-results (append results (list value)))) + (if (empty? remaining) + (make-cek-value new-results fenv rest-k) + (let ((call-args (if indexed + (list (len new-results) (first remaining)) + (list (first remaining)))) + (next-frame (if indexed + (make-map-indexed-frame f (rest remaining) new-results fenv) + (make-map-frame f (rest remaining) new-results fenv)))) + (continue-with-call f call-args fenv (list) + (kont-push next-frame rest-k)))))) + + ;; --- FilterFrame: predicate result --- + (= ft "filter") + (let ((f (get frame "f")) + (remaining (get frame "remaining")) + (results (get frame "results")) + (current-item (get frame "current-item")) + (fenv (get frame "env"))) + (let ((new-results (if value + (append results (list current-item)) + results))) + (if (empty? remaining) + (make-cek-value new-results fenv rest-k) + (continue-with-call f (list (first remaining)) fenv (list) + (kont-push (make-filter-frame f (rest remaining) new-results (first remaining) fenv) rest-k))))) + + ;; --- ReduceFrame: accumulator step --- + (= ft "reduce") + (let ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if (empty? remaining) + (make-cek-value value fenv rest-k) + (continue-with-call f (list value (first remaining)) fenv (list) + (kont-push (make-reduce-frame f (rest remaining) fenv) rest-k)))) + + ;; --- ForEachFrame: side effect, discard result --- + (= ft "for-each") + (let ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if (empty? remaining) + (make-cek-value nil fenv rest-k) + (continue-with-call f (list (first remaining)) fenv (list) + (kont-push (make-for-each-frame f (rest remaining) fenv) rest-k)))) + + ;; --- SomeFrame: short-circuit on first truthy --- + (= ft "some") + (let ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if value + (make-cek-value value fenv rest-k) + (if (empty? remaining) + (make-cek-value false fenv rest-k) + (continue-with-call f (list (first remaining)) fenv (list) + (kont-push (make-some-frame f (rest remaining) fenv) rest-k))))) + + ;; --- EveryFrame: short-circuit on first falsy --- + (= ft "every") + (let ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if (not value) + (make-cek-value false fenv rest-k) + (if (empty? remaining) + (make-cek-value true fenv rest-k) + (continue-with-call f (list (first remaining)) fenv (list) + (kont-push (make-every-frame f (rest remaining) fenv) rest-k))))) + + :else (error (str "Unknown frame type: " ft)))))))) + + +;; -------------------------------------------------------------------------- +;; 9. Helper: continue with function call +;; -------------------------------------------------------------------------- + +(define continue-with-call + (fn (f args env raw-args kont) + (cond + ;; Continuation — restore captured frames and inject value + (continuation? f) + (let ((arg (if (empty? args) nil (first args))) + (cont-data (continuation-data f))) + (let ((captured (get cont-data "captured")) + (rest-k (get cont-data "rest-kont"))) + (make-cek-value arg env (concat captured rest-k)))) + + ;; Native callable + (and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f))) + (make-cek-value (apply f args) env kont) + + ;; Lambda — bind params, evaluate body + (lambda? f) + (let ((params (lambda-params f)) + (local (env-merge (lambda-closure f) env))) + (if (> (len args) (len params)) + (error (str (or (lambda-name f) "lambda") + " expects " (len params) " args, got " (len args))) + (do + (for-each + (fn (pair) (env-set! local (first pair) (nth pair 1))) + (zip params args)) + (for-each + (fn (p) (env-set! local p nil)) + (slice params (len args))) + (make-cek-state (lambda-body f) local kont)))) + + ;; Component — parse kwargs, bind, evaluate body + (or (component? f) (island? f)) + (let ((parsed (parse-keyword-args raw-args env)) + (kwargs (first parsed)) + (children (nth parsed 1)) + (local (env-merge (component-closure f) env))) + (for-each + (fn (p) (env-set! local p (or (dict-get kwargs p) nil))) + (component-params f)) + (when (component-has-children? f) + (env-set! local "children" children)) + (make-cek-state (component-body f) local kont)) + + :else (error (str "Not callable: " (inspect f)))))) + + +;; -------------------------------------------------------------------------- +;; 10. Case step loop helper +;; -------------------------------------------------------------------------- + +(define sf-case-step-loop + (fn (match-val clauses env kont) + (if (< (len clauses) 2) + (make-cek-value nil env kont) + (let ((test (first clauses)) + (body (nth clauses 1))) + (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) + (and (= (type-of test) "symbol") + (or (= (symbol-name test) "else") + (= (symbol-name test) ":else")))) + (make-cek-state body env kont) + ;; Evaluate test expression + (let ((test-val (trampoline (eval-expr test env)))) + (if (= match-val test-val) + (make-cek-state body env kont) + (sf-case-step-loop match-val (slice clauses 2) env kont)))))))) + + +;; -------------------------------------------------------------------------- +;; 11. Compatibility wrapper — eval-expr-cek +;; -------------------------------------------------------------------------- +;; +;; Drop-in replacement for eval-expr. Creates a CEK state and runs. +;; All downstream code (adapters, services) works unchanged. + +(define eval-expr-cek + (fn (expr env) + (cek-run (make-cek-state expr env (list))))) + +(define trampoline-cek + (fn (val) + ;; In CEK mode, thunks are not produced — values are immediate. + ;; But for compatibility, resolve any remaining thunks. + (if (thunk? val) + (eval-expr-cek (thunk-expr val) (thunk-env val)) + val))) + + + +;; -------------------------------------------------------------------------- +;; 13. Freeze scopes — named serializable state boundaries +;; -------------------------------------------------------------------------- +;; +;; A freeze scope collects signals registered within it. On freeze, +;; their current values are serialized to SX. On thaw, values are +;; restored. Multiple named scopes can coexist independently. +;; +;; Uses the scoped effects system: scope-push!/scope-pop!/context. +;; +;; Usage: +;; (freeze-scope "editor" +;; (let ((doc (signal "hello"))) +;; (freeze-signal "doc" doc) +;; ...)) +;; +;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}} +;; (cek-thaw-scope "editor" frozen-data) → restores signal values + +;; Registry of freeze scopes: name → list of {name signal} entries +(define freeze-registry (dict)) + +;; Register a signal in the current freeze scope +(define freeze-signal :effects [mutation] + (fn (name sig) + (let ((scope-name (context "sx-freeze-scope" nil))) + (when scope-name + (let ((entries (or (get freeze-registry scope-name) (list)))) + (append! entries (dict "name" name "signal" sig)) + (dict-set! freeze-registry scope-name entries)))))) + +;; Freeze scope delimiter — collects signals registered within body +(define freeze-scope :effects [mutation] + (fn (name body-fn) + (scope-push! "sx-freeze-scope" name) + ;; Initialize empty entry list for this scope + (dict-set! freeze-registry name (list)) + (cek-call body-fn nil) + (scope-pop! "sx-freeze-scope") + nil)) + +;; Freeze a named scope → SX dict of signal values +(define cek-freeze-scope :effects [] + (fn (name) + (let ((entries (or (get freeze-registry name) (list))) + (signals-dict (dict))) + (for-each (fn (entry) + (dict-set! signals-dict + (get entry "name") + (signal-value (get entry "signal")))) + entries) + (dict "name" name "signals" signals-dict)))) + +;; Freeze all scopes +(define cek-freeze-all :effects [] + (fn () + (map (fn (name) (cek-freeze-scope name)) + (keys freeze-registry)))) + +;; Thaw a named scope — restore signal values from frozen data +(define cek-thaw-scope :effects [mutation] + (fn (name frozen) + (let ((entries (or (get freeze-registry name) (list))) + (values (get frozen "signals"))) + (when values + (for-each (fn (entry) + (let ((sig-name (get entry "name")) + (sig (get entry "signal")) + (val (get values sig-name))) + (when (not (nil? val)) + (reset! sig val)))) + entries))))) + +;; Thaw all scopes from a list of frozen scope dicts +(define cek-thaw-all :effects [mutation] + (fn (frozen-list) + (for-each (fn (frozen) + (cek-thaw-scope (get frozen "name") frozen)) + frozen-list))) + +;; Serialize a frozen scope to SX text +(define freeze-to-sx :effects [] + (fn (name) + (sx-serialize (cek-freeze-scope name)))) + +;; Restore from SX text +(define thaw-from-sx :effects [mutation] + (fn (sx-text) + (let ((parsed (sx-parse sx-text))) + (when (not (empty? parsed)) + (let ((frozen (first parsed))) + (cek-thaw-scope (get frozen "name") frozen)))))) + + + + +;; -------------------------------------------------------------------------- +;; 14. Content-addressed computation +;; -------------------------------------------------------------------------- +;; +;; Hash frozen SX to a content identifier. Store and retrieve by CID. +;; The content IS the address — same SX always produces the same CID. +;; +;; Uses an in-memory content store. Applications can persist to +;; localStorage or IPFS by providing their own store backend. + +(define content-store (dict)) + +(define content-hash :effects [] + (fn (sx-text) + ;; djb2 hash → hex string. Simple, deterministic, fast. + ;; Real deployment would use SHA-256 / multihash. + (let ((hash 5381)) + (for-each (fn (i) + (set! hash (mod (+ (* hash 33) (char-code-at sx-text i)) 4294967296))) + (range 0 (len sx-text))) + (to-hex hash)))) + +(define content-put :effects [mutation] + (fn (sx-text) + (let ((cid (content-hash sx-text))) + (dict-set! content-store cid sx-text) + cid))) + +(define content-get :effects [] + (fn (cid) + (get content-store cid))) + +;; Freeze a scope → store → return CID +(define freeze-to-cid :effects [mutation] + (fn (scope-name) + (let ((sx-text (freeze-to-sx scope-name))) + (content-put sx-text)))) + +;; Thaw from CID → look up → restore +(define thaw-from-cid :effects [mutation] + (fn (cid) + (let ((sx-text (content-get cid))) + (when sx-text + (thaw-from-sx sx-text) + true)))) diff --git a/spec/continuations.sx b/spec/continuations.sx new file mode 100644 index 0000000..b5ae623 --- /dev/null +++ b/spec/continuations.sx @@ -0,0 +1,248 @@ +;; ========================================================================== +;; continuations.sx — Delimited continuations (shift/reset) +;; +;; OPTIONAL EXTENSION — not required by the core evaluator. +;; Bootstrappers include this only when the target requests it. +;; +;; Delimited continuations capture "the rest of the computation up to +;; a delimiter." They are strictly less powerful than full call/cc but +;; cover the practical use cases: suspendable rendering, cooperative +;; scheduling, linear async flows, wizard forms, and undo. +;; +;; Two new special forms: +;; (reset body) — establish a delimiter +;; (shift k body) — capture the continuation to the nearest reset +;; +;; One new type: +;; continuation — a captured delimited continuation, callable +;; +;; The captured continuation is a function of one argument. Invoking it +;; provides the value that the shift expression "returns" within the +;; delimited context, then completes the rest of the reset body. +;; +;; Continuations are composable — invoking a continuation returns a +;; value (the result of the reset body), which can be used normally. +;; This is the key difference from undelimited call/cc, where invoking +;; a continuation never returns. +;; +;; Platform requirements: +;; (make-continuation fn) — wrap a function as a continuation value +;; (continuation? x) — type predicate +;; (type-of continuation) → "continuation" +;; Continuations are callable (same dispatch as lambda). +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. Type +;; -------------------------------------------------------------------------- +;; +;; A continuation is a callable value of one argument. +;; +;; (continuation? k) → true if k is a captured continuation +;; (type-of k) → "continuation" +;; (k value) → invoke: resume the captured computation with value +;; +;; Continuations are first-class: they can be stored in variables, passed +;; as arguments, returned from functions, and put in data structures. +;; +;; Invoking a delimited continuation RETURNS a value — the result of the +;; reset body. This makes them composable: +;; +;; (+ 1 (reset (+ 10 (shift k (k 5))))) +;; ;; k is "add 10 to _ and return from reset" +;; ;; (k 5) → 15, which is returned from reset +;; ;; (+ 1 15) → 16 +;; +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 2. reset — establish a continuation delimiter +;; -------------------------------------------------------------------------- +;; +;; (reset body) +;; +;; Evaluates body in the current environment. If no shift occurs during +;; evaluation of body, reset simply returns the value of body. +;; +;; If shift occurs, reset is the boundary — the continuation captured by +;; shift extends from the shift point back to (and including) this reset. +;; +;; reset is the "prompt" — it marks where the continuation stops. +;; +;; Semantics: +;; (reset expr) where expr contains no shift +;; → (eval expr env) ;; just evaluates normally +;; +;; (reset ... (shift k body) ...) +;; → captures continuation, evaluates shift's body +;; → the result of the shift body is the result of the reset +;; +;; -------------------------------------------------------------------------- + +(define sf-reset + (fn ((args :as list) (env :as dict)) + ;; Single argument: the body expression. + ;; Install a continuation delimiter, then evaluate body. + ;; The implementation is target-specific: + ;; - In Scheme: native reset/shift + ;; - In Haskell: Control.Monad.CC or delimited continuations library + ;; - In Python: coroutine/generator-based (see implementation notes) + ;; - In JavaScript: generator-based or CPS transform + ;; - In Rust: CPS transform at compile time + (let ((body (first args))) + (eval-with-delimiter body env)))) + + +;; -------------------------------------------------------------------------- +;; 3. shift — capture the continuation to the nearest reset +;; -------------------------------------------------------------------------- +;; +;; (shift k body) +;; +;; Captures the continuation from this point back to the nearest enclosing +;; reset and binds it to k. Then evaluates body in the current environment +;; extended with k. The result of body becomes the result of the enclosing +;; reset. +;; +;; k is a function of one argument. Calling (k value) resumes the captured +;; computation with value standing in for the shift expression. +;; +;; The continuation k is composable: (k value) returns a value (the result +;; of the reset body when resumed with value). This means k can be called +;; multiple times, and its result can be used in further computation. +;; +;; Examples: +;; +;; ;; Basic: shift provides a value to the surrounding computation +;; (reset (+ 1 (shift k (k 41)))) +;; ;; k = "add 1 to _", (k 41) → 42, reset returns 42 +;; +;; ;; Abort: shift can discard the continuation entirely +;; (reset (+ 1 (shift k "aborted"))) +;; ;; k is never called, reset returns "aborted" +;; +;; ;; Multiple invocations: k can be called more than once +;; (reset (+ 1 (shift k (list (k 10) (k 20))))) +;; ;; (k 10) → 11, (k 20) → 21, reset returns (11 21) +;; +;; ;; Stored for later: k can be saved and invoked outside reset +;; (define saved nil) +;; (reset (+ 1 (shift k (set! saved k) 0))) +;; ;; reset returns 0, saved holds the continuation +;; (saved 99) ;; → 100 +;; +;; -------------------------------------------------------------------------- + +(define sf-shift + (fn ((args :as list) (env :as dict)) + ;; Two arguments: the continuation variable name, and the body. + (let ((k-name (symbol-name (first args))) + (body (second args))) + ;; Capture the current continuation up to the nearest reset. + ;; Bind it to k-name in the environment, then evaluate body. + ;; The result of body is returned to the reset. + (capture-continuation k-name body env)))) + + +;; -------------------------------------------------------------------------- +;; 4. Interaction with other features +;; -------------------------------------------------------------------------- +;; +;; TCO (trampoline): +;; Continuations interact naturally with the trampoline. A shift inside +;; a tail-call position captures the continuation including the pending +;; return. The trampoline resolves thunks before the continuation is +;; delimited. +;; +;; Macros: +;; shift/reset are special forms, not macros. Macros expand before +;; evaluation, so shift inside a macro-expanded form works correctly — +;; it captures the continuation of the expanded code. +;; +;; Components: +;; shift inside a component body captures the continuation of that +;; component's render. The enclosing reset determines the delimiter. +;; This is the foundation for suspendable rendering — a component can +;; shift to suspend, and the server resumes it when data arrives. +;; +;; I/O primitives: +;; I/O primitives execute at invocation time, in whatever context +;; exists then. A continuation that captures a computation containing +;; I/O will re-execute that I/O when invoked. If the I/O requires +;; request context (e.g. current-user), invoking the continuation +;; outside a request will fail — same as calling the I/O directly. +;; This is consistent, not a restriction. +;; +;; In typed targets (Haskell, Rust), the type system can enforce that +;; continuations containing I/O are only invoked in appropriate contexts. +;; In dynamic targets (Python, JS), it fails at runtime. +;; +;; Lexical scope: +;; Continuations capture the dynamic extent (what happens next) but +;; close over the lexical environment at the point of capture. Variable +;; bindings in the continuation refer to the same environment — mutations +;; via set! are visible. +;; +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 5. Implementation notes per target +;; -------------------------------------------------------------------------- +;; +;; The bootstrapper emits target-specific continuation machinery. +;; The spec defines semantics; each target chooses representation. +;; +;; Scheme / Racket: +;; Native shift/reset. No transformation needed. The bootstrapper +;; emits (require racket/control) or equivalent. +;; +;; Haskell: +;; Control.Monad.CC provides delimited continuations in the CC monad. +;; Alternatively, the evaluator can be CPS-transformed at compile time. +;; Continuations become first-class functions naturally. +;; +;; Python: +;; Generator-based: reset creates a generator, shift yields from it. +;; The trampoline loop drives the generator. Each yield is a shift +;; point, and send() provides the resume value. +;; Alternative: greenlet-based (stackful coroutines). +;; +;; JavaScript: +;; Generator-based (function* / yield). Similar to Python. +;; Alternative: CPS transform at bootstrap time — the bootstrapper +;; rewrites the evaluator into continuation-passing style, making +;; shift/reset explicit function arguments. +;; +;; Rust: +;; CPS transform at compile time. Continuations become enum variants +;; or boxed closures. The type system ensures continuations are used +;; linearly if desired (affine types via ownership). +;; +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 6. Platform interface — what each target must provide +;; -------------------------------------------------------------------------- +;; +;; (eval-with-delimiter expr env) +;; Install a reset delimiter, evaluate expr, return result. +;; If expr calls shift, the continuation is captured up to here. +;; +;; (capture-continuation k-name body env) +;; Capture the current continuation up to the nearest delimiter. +;; Bind it to k-name in env, evaluate body, return result to delimiter. +;; +;; (make-continuation fn) +;; Wrap a native function as a continuation value. +;; +;; (continuation? x) +;; Type predicate. +;; +;; Continuations must be callable via the standard function-call +;; dispatch in eval-list (same path as lambda calls). +;; +;; -------------------------------------------------------------------------- diff --git a/spec/eval.sx b/spec/eval.sx new file mode 100644 index 0000000..6429880 --- /dev/null +++ b/spec/eval.sx @@ -0,0 +1,1184 @@ +;; ========================================================================== +;; eval.sx — Reference SX evaluator written in SX +;; +;; This is the canonical specification of SX evaluation semantics. +;; A thin bootstrap compiler per target reads this file and emits +;; a native evaluator (JavaScript, Python, Rust, etc.). +;; +;; The evaluator is written in a restricted subset of SX: +;; - defcomp, define, defmacro, lambda/fn +;; - if, when, cond, case, let, do, and, or +;; - map, filter, reduce, some, every? +;; - Primitives: list ops, string ops, arithmetic, predicates +;; - quote, quasiquote/unquote/splice-unquote +;; - Pattern matching via (case (type-of expr) ...) +;; +;; Platform-specific concerns (DOM rendering, async I/O, HTML emission) +;; are declared as interfaces — each target provides its own adapter. +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. Types +;; -------------------------------------------------------------------------- +;; +;; The evaluator operates on these value types: +;; +;; number — integer or float +;; string — double-quoted text +;; boolean — true / false +;; nil — singleton null +;; symbol — unquoted identifier (e.g. div, ~card, map) +;; keyword — colon-prefixed key (e.g. :class, :id) +;; list — ordered sequence (also used as code) +;; dict — string-keyed hash map +;; lambda — closure: {params, body, closure-env, name?} +;; macro — AST transformer: {params, rest-param, body, closure-env} +;; component — UI component: {name, params, has-children, body, closure-env} +;; island — reactive component: like component but with island flag +;; thunk — deferred eval for TCO: {expr, env} +;; +;; Each target must provide: +;; (type-of x) → one of the strings above +;; (make-lambda ...) → platform Lambda value +;; (make-component ..) → platform Component value +;; (make-island ...) → platform Island value (component + island flag) +;; (make-macro ...) → platform Macro value +;; (make-thunk ...) → platform Thunk value +;; +;; These are declared in platform.sx and implemented per target. +;; -------------------------------------------------------------------------- + + +;; -------------------------------------------------------------------------- +;; 2. Trampoline — tail-call optimization +;; -------------------------------------------------------------------------- + +(define trampoline + (fn ((val :as any)) + ;; Iteratively resolve thunks until we get an actual value. + ;; Each target implements thunk? and thunk-expr/thunk-env. + (let ((result val)) + (do + ;; Loop while result is a thunk + ;; Note: this is pseudo-iteration — bootstrap compilers convert + ;; this tail-recursive form to a while loop. + (if (thunk? result) + (trampoline (eval-expr (thunk-expr result) (thunk-env result))) + result))))) + + +;; -------------------------------------------------------------------------- +;; 3. Core evaluator +;; -------------------------------------------------------------------------- + +(define eval-expr + (fn (expr (env :as dict)) + (case (type-of expr) + + ;; --- literals pass through --- + "number" expr + "string" expr + "boolean" expr + "nil" nil + + ;; --- symbol lookup --- + "symbol" + (let ((name (symbol-name expr))) + (cond + (env-has? env name) (env-get env name) + (primitive? name) (get-primitive name) + (= name "true") true + (= name "false") false + (= name "nil") nil + :else (do (debug-log "Undefined symbol:" name "primitive?:" (primitive? name)) + (error (str "Undefined symbol: " name))))) + + ;; --- keyword → its string name --- + "keyword" (keyword-name expr) + + ;; --- dict literal --- + "dict" + (map-dict (fn (k v) (trampoline (eval-expr v env))) expr) + + ;; --- list = call or special form --- + "list" + (if (empty? expr) + (list) + (eval-list expr env)) + + ;; --- anything else passes through --- + :else expr))) + + +;; -------------------------------------------------------------------------- +;; 4. List evaluation — dispatch on head +;; -------------------------------------------------------------------------- + +(define eval-list + (fn (expr (env :as dict)) + (let ((head (first expr)) + (args (rest expr))) + + ;; If head isn't a symbol, lambda, or list → treat as data list + (if (not (or (= (type-of head) "symbol") + (= (type-of head) "lambda") + (= (type-of head) "list"))) + (map (fn (x) (trampoline (eval-expr x env))) expr) + + ;; Head is a symbol — check special forms, then function call + (if (= (type-of head) "symbol") + (let ((name (symbol-name head))) + (cond + ;; Special forms + (= name "if") (sf-if args env) + (= name "when") (sf-when args env) + (= name "cond") (sf-cond args env) + (= name "case") (sf-case args env) + (= name "and") (sf-and args env) + (= name "or") (sf-or args env) + (= name "let") (sf-let args env) + (= name "let*") (sf-let args env) + (= name "letrec") (sf-letrec args env) + (= name "lambda") (sf-lambda args env) + (= name "fn") (sf-lambda args env) + (= name "define") (sf-define args env) + (= name "defcomp") (sf-defcomp args env) + (= name "defisland") (sf-defisland args env) + (= name "defmacro") (sf-defmacro args env) + (= name "defstyle") (sf-defstyle args env) + (= name "defhandler") (sf-defhandler args env) + (= name "defpage") (sf-defpage args env) + (= name "defquery") (sf-defquery args env) + (= name "defaction") (sf-defaction args env) + (= name "deftype") (sf-deftype args env) + (= name "defeffect") (sf-defeffect args env) + (= name "begin") (sf-begin args env) + (= name "do") (sf-begin args env) + (= name "quote") (sf-quote args env) + (= name "quasiquote") (sf-quasiquote args env) + (= name "->") (sf-thread-first args env) + (= name "set!") (sf-set! args env) + (= name "reset") (sf-reset args env) + (= name "shift") (sf-shift args env) + (= name "dynamic-wind") (sf-dynamic-wind args env) + (= name "scope") (sf-scope args env) + (= name "provide") (sf-provide args env) + + ;; Higher-order forms + (= name "map") (ho-map args env) + (= name "map-indexed") (ho-map-indexed args env) + (= name "filter") (ho-filter args env) + (= name "reduce") (ho-reduce args env) + (= name "some") (ho-some args env) + (= name "every?") (ho-every args env) + (= name "for-each") (ho-for-each args env) + + ;; Macro expansion + (and (env-has? env name) (macro? (env-get env name))) + (let ((mac (env-get env name))) + (make-thunk (expand-macro mac args env) env)) + + ;; Render expression — delegate to active adapter (only when rendering). + (and (render-active?) (is-render-expr? expr)) + (render-expr expr env) + + ;; Fall through to function call + :else (eval-call head args env))) + + ;; Head is lambda or list — evaluate as function call + (eval-call head args env)))))) + + +;; -------------------------------------------------------------------------- +;; 5. Function / lambda / component call +;; -------------------------------------------------------------------------- + +(define eval-call + (fn (head (args :as list) (env :as dict)) + (let ((f (trampoline (eval-expr head env))) + (evaluated-args (map (fn (a) (trampoline (eval-expr a env))) args))) + (cond + ;; Native callable (primitive function) + (and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f))) + (apply f evaluated-args) + + ;; Lambda + (lambda? f) + (call-lambda f evaluated-args env) + + ;; Component + (component? f) + (call-component f args env) + + ;; Island (reactive component) — same calling convention + (island? f) + (call-component f args env) + + :else (error (str "Not callable: " (inspect f))))))) + + +(define call-lambda + (fn ((f :as lambda) (args :as list) (caller-env :as dict)) + (let ((params (lambda-params f)) + (local (env-merge (lambda-closure f) caller-env))) + ;; Too many args is an error; too few pads with nil + (if (> (len args) (len params)) + (error (str (or (lambda-name f) "lambda") + " expects " (len params) " args, got " (len args))) + (do + ;; Bind params — provided args first, then nil for missing + (for-each + (fn (pair) (env-set! local (first pair) (nth pair 1))) + (zip params args)) + (for-each + (fn (p) (env-set! local p nil)) + (slice params (len args))) + ;; Return thunk for TCO + (make-thunk (lambda-body f) local)))))) + + +(define call-component + (fn ((comp :as component) (raw-args :as list) (env :as dict)) + ;; Parse keyword args and children from unevaluated arg list + (let ((parsed (parse-keyword-args raw-args env)) + (kwargs (first parsed)) + (children (nth parsed 1)) + (local (env-merge (component-closure comp) env))) + ;; Bind keyword params + (for-each + (fn (p) (env-set! local p (or (dict-get kwargs p) nil))) + (component-params comp)) + ;; Bind children if component accepts them + (when (component-has-children? comp) + (env-set! local "children" children)) + ;; Return thunk — body evaluated in local env + (make-thunk (component-body comp) local)))) + + +(define parse-keyword-args + (fn ((raw-args :as list) (env :as dict)) + ;; Walk args: keyword + next-val → kwargs dict, else → children list + (let ((kwargs (dict)) + (children (list)) + (i 0)) + ;; Iterative parse — bootstrap converts to while loop + (reduce + (fn (state arg) + (let ((idx (get state "i")) + (skip (get state "skip"))) + (if skip + ;; This arg was consumed as a keyword value + (assoc state "skip" false "i" (inc idx)) + (if (and (= (type-of arg) "keyword") + (< (inc idx) (len raw-args))) + ;; Keyword: evaluate next arg and store + (do + (dict-set! kwargs (keyword-name arg) + (trampoline (eval-expr (nth raw-args (inc idx)) env))) + (assoc state "skip" true "i" (inc idx))) + ;; Positional: evaluate and add to children + (do + (append! children (trampoline (eval-expr arg env))) + (assoc state "i" (inc idx))))))) + (dict "i" 0 "skip" false) + raw-args) + (list kwargs children)))) + + +;; -------------------------------------------------------------------------- +;; 6. Special forms +;; -------------------------------------------------------------------------- + +(define sf-if + (fn ((args :as list) (env :as dict)) + (let ((condition (trampoline (eval-expr (first args) env)))) + (if (and condition (not (nil? condition))) + (make-thunk (nth args 1) env) + (if (> (len args) 2) + (make-thunk (nth args 2) env) + nil))))) + + +(define sf-when + (fn ((args :as list) (env :as dict)) + (let ((condition (trampoline (eval-expr (first args) env)))) + (if (and condition (not (nil? condition))) + (do + ;; Evaluate all but last for side effects + (for-each + (fn (e) (trampoline (eval-expr e env))) + (slice args 1 (dec (len args)))) + ;; Last is tail position + (make-thunk (last args) env)) + nil)))) + + +;; cond-scheme? — check if ALL clauses are 2-element lists (scheme-style). +;; Checking only the first arg is ambiguous — (nil? x) is a 2-element +;; function call, not a scheme clause ((test body)). +(define cond-scheme? + (fn ((clauses :as list)) + (every? (fn (c) (and (= (type-of c) "list") (= (len c) 2))) + clauses))) + +(define sf-cond + (fn ((args :as list) (env :as dict)) + (if (cond-scheme? args) + (sf-cond-scheme args env) + (sf-cond-clojure args env)))) + +(define sf-cond-scheme + (fn ((clauses :as list) (env :as dict)) + (if (empty? clauses) + nil + (let ((clause (first clauses)) + (test (first clause)) + (body (nth clause 1))) + (if (or (and (= (type-of test) "symbol") + (or (= (symbol-name test) "else") + (= (symbol-name test) ":else"))) + (and (= (type-of test) "keyword") + (= (keyword-name test) "else"))) + (make-thunk body env) + (if (trampoline (eval-expr test env)) + (make-thunk body env) + (sf-cond-scheme (rest clauses) env))))))) + +(define sf-cond-clojure + (fn ((clauses :as list) (env :as dict)) + (if (< (len clauses) 2) + nil + (let ((test (first clauses)) + (body (nth clauses 1))) + (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) + (and (= (type-of test) "symbol") + (or (= (symbol-name test) "else") + (= (symbol-name test) ":else")))) + (make-thunk body env) + (if (trampoline (eval-expr test env)) + (make-thunk body env) + (sf-cond-clojure (slice clauses 2) env))))))) + + +(define sf-case + (fn ((args :as list) (env :as dict)) + (let ((match-val (trampoline (eval-expr (first args) env))) + (clauses (rest args))) + (sf-case-loop match-val clauses env)))) + +(define sf-case-loop + (fn (match-val (clauses :as list) (env :as dict)) + (if (< (len clauses) 2) + nil + (let ((test (first clauses)) + (body (nth clauses 1))) + (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) + (and (= (type-of test) "symbol") + (or (= (symbol-name test) "else") + (= (symbol-name test) ":else")))) + (make-thunk body env) + (if (= match-val (trampoline (eval-expr test env))) + (make-thunk body env) + (sf-case-loop match-val (slice clauses 2) env))))))) + + +(define sf-and + (fn ((args :as list) (env :as dict)) + (if (empty? args) + true + (let ((val (trampoline (eval-expr (first args) env)))) + (if (not val) + val + (if (= (len args) 1) + val + (sf-and (rest args) env))))))) + + +(define sf-or + (fn ((args :as list) (env :as dict)) + (if (empty? args) + false + (let ((val (trampoline (eval-expr (first args) env)))) + (if val + val + (sf-or (rest args) env)))))) + + +(define sf-let + (fn ((args :as list) (env :as dict)) + ;; Detect named let: (let name ((x 0) ...) body) + ;; If first arg is a symbol, delegate to sf-named-let. + (if (= (type-of (first args)) "symbol") + (sf-named-let args env) + (let ((bindings (first args)) + (body (rest args)) + (local (env-extend env))) + ;; Parse bindings — support both ((name val) ...) and (name val name val ...) + (if (and (= (type-of (first bindings)) "list") + (= (len (first bindings)) 2)) + ;; Scheme-style + (for-each + (fn (binding) + (let ((vname (if (= (type-of (first binding)) "symbol") + (symbol-name (first binding)) + (first binding)))) + (env-set! local vname (trampoline (eval-expr (nth binding 1) local))))) + bindings) + ;; Clojure-style + (let ((i 0)) + (reduce + (fn (acc pair-idx) + (let ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol") + (symbol-name (nth bindings (* pair-idx 2))) + (nth bindings (* pair-idx 2)))) + (val-expr (nth bindings (inc (* pair-idx 2))))) + (env-set! local vname (trampoline (eval-expr val-expr local))))) + nil + (range 0 (/ (len bindings) 2))))) + ;; Evaluate body — last expression in tail position + (for-each + (fn (e) (trampoline (eval-expr e local))) + (slice body 0 (dec (len body)))) + (make-thunk (last body) local))))) + + +;; Named let: (let name ((x 0) (y 1)) body...) +;; Desugars to a self-recursive lambda called with initial values. +;; The loop name is bound in the body so recursive calls produce TCO thunks. +(define sf-named-let + (fn ((args :as list) (env :as dict)) + (let ((loop-name (symbol-name (first args))) + (bindings (nth args 1)) + (body (slice args 2)) + (params (list)) + (inits (list))) + ;; Extract param names and init expressions + (if (and (= (type-of (first bindings)) "list") + (= (len (first bindings)) 2)) + ;; Scheme-style: ((x 0) (y 1)) + (for-each + (fn (binding) + (append! params (if (= (type-of (first binding)) "symbol") + (symbol-name (first binding)) + (first binding))) + (append! inits (nth binding 1))) + bindings) + ;; Clojure-style: (x 0 y 1) + (reduce + (fn (acc pair-idx) + (do + (append! params (if (= (type-of (nth bindings (* pair-idx 2))) "symbol") + (symbol-name (nth bindings (* pair-idx 2))) + (nth bindings (* pair-idx 2)))) + (append! inits (nth bindings (inc (* pair-idx 2)))))) + nil + (range 0 (/ (len bindings) 2)))) + ;; Build loop body (wrap in begin if multiple exprs) + (let ((loop-body (if (= (len body) 1) (first body) + (cons (make-symbol "begin") body))) + (loop-fn (make-lambda params loop-body env))) + ;; Self-reference: loop can call itself by name + (set-lambda-name! loop-fn loop-name) + (env-set! (lambda-closure loop-fn) loop-name loop-fn) + ;; Evaluate initial values in enclosing env, then call + (let ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits))) + (call-lambda loop-fn init-vals env)))))) + + +(define sf-lambda + (fn ((args :as list) (env :as dict)) + (let ((params-expr (first args)) + (body-exprs (rest args)) + (body (if (= (len body-exprs) 1) + (first body-exprs) + (cons (make-symbol "begin") body-exprs))) + (param-names (map (fn (p) + (cond + (= (type-of p) "symbol") + (symbol-name p) + ;; Annotated param: (name :as type) → extract name + (and (= (type-of p) "list") + (= (len p) 3) + (= (type-of (nth p 1)) "keyword") + (= (keyword-name (nth p 1)) "as")) + (symbol-name (first p)) + :else p)) + params-expr))) + (make-lambda param-names body env)))) + + +(define sf-define + (fn ((args :as list) (env :as dict)) + ;; Detect :effects keyword: (define name :effects [...] value) + (let ((name-sym (first args)) + (has-effects (and (>= (len args) 4) + (= (type-of (nth args 1)) "keyword") + (= (keyword-name (nth args 1)) "effects"))) + (val-idx (if (and (>= (len args) 4) + (= (type-of (nth args 1)) "keyword") + (= (keyword-name (nth args 1)) "effects")) + 3 1)) + (value (trampoline (eval-expr (nth args val-idx) env)))) + (when (and (lambda? value) (nil? (lambda-name value))) + (set-lambda-name! value (symbol-name name-sym))) + (env-set! env (symbol-name name-sym) value) + ;; Store effect annotation if declared + (when has-effects + (let ((effects-raw (nth args 2)) + (effect-list (if (= (type-of effects-raw) "list") + (map (fn (e) (if (= (type-of e) "symbol") + (symbol-name e) (str e))) + effects-raw) + (list (str effects-raw)))) + (effect-anns (if (env-has? env "*effect-annotations*") + (env-get env "*effect-annotations*") + (dict)))) + (dict-set! effect-anns (symbol-name name-sym) effect-list) + (env-set! env "*effect-annotations*" effect-anns))) + value))) + + +(define sf-defcomp + (fn ((args :as list) (env :as dict)) + ;; (defcomp ~name (params) [:affinity :client|:server] body) + ;; Body is always the last element. Optional keyword annotations + ;; may appear between the params list and the body. + (let ((name-sym (first args)) + (params-raw (nth args 1)) + (body (last args)) + (comp-name (strip-prefix (symbol-name name-sym) "~")) + (parsed (parse-comp-params params-raw)) + (params (first parsed)) + (has-children (nth parsed 1)) + (param-types (nth parsed 2)) + (affinity (defcomp-kwarg args "affinity" "auto"))) + (let ((comp (make-component comp-name params has-children body env affinity)) + (effects (defcomp-kwarg args "effects" nil))) + ;; Store type annotations if any were declared + (when (and (not (nil? param-types)) + (not (empty? (keys param-types)))) + (component-set-param-types! comp param-types)) + ;; Store effect annotation if declared + (when (not (nil? effects)) + (let ((effect-list (if (= (type-of effects) "list") + (map (fn (e) (if (= (type-of e) "symbol") + (symbol-name e) (str e))) + effects) + (list (str effects)))) + (effect-anns (if (env-has? env "*effect-annotations*") + (env-get env "*effect-annotations*") + (dict)))) + (dict-set! effect-anns (symbol-name name-sym) effect-list) + (env-set! env "*effect-annotations*" effect-anns))) + (env-set! env (symbol-name name-sym) comp) + comp)))) + +(define defcomp-kwarg + (fn ((args :as list) (key :as string) default) + ;; Search for :key value between params (index 2) and body (last). + (let ((end (- (len args) 1)) + (result default)) + (for-each + (fn (i) + (when (and (= (type-of (nth args i)) "keyword") + (= (keyword-name (nth args i)) key) + (< (+ i 1) end)) + (let ((val (nth args (+ i 1)))) + (set! result (if (= (type-of val) "keyword") + (keyword-name val) val))))) + (range 2 end 1)) + result))) + +(define parse-comp-params + (fn ((params-expr :as list)) + ;; Parse (&key param1 param2 &children) → (params has-children param-types) + ;; Also accepts &rest as synonym for &children. + ;; Supports typed params: (name :as type) — a 3-element list where + ;; the second element is the keyword :as. Unannotated params get no + ;; type entry. param-types is a dict {name → type-expr} or empty dict. + (let ((params (list)) + (param-types (dict)) + (has-children false) + (in-key false)) + (for-each + (fn (p) + (if (and (= (type-of p) "list") + (= (len p) 3) + (= (type-of (first p)) "symbol") + (= (type-of (nth p 1)) "keyword") + (= (keyword-name (nth p 1)) "as")) + ;; Typed param: (name :as type) + (let ((name (symbol-name (first p))) + (ptype (nth p 2))) + ;; Convert type to string if it's a symbol + (let ((type-val (if (= (type-of ptype) "symbol") + (symbol-name ptype) + ptype))) + (when (not has-children) + (append! params name) + (dict-set! param-types name type-val)))) + ;; Untyped param or marker + (when (= (type-of p) "symbol") + (let ((name (symbol-name p))) + (cond + (= name "&key") (set! in-key true) + (= name "&rest") (set! has-children true) + (= name "&children") (set! has-children true) + has-children nil ;; skip params after &children/&rest + in-key (append! params name) + :else (append! params name)))))) + params-expr) + (list params has-children param-types)))) + + +(define sf-defisland + (fn ((args :as list) (env :as dict)) + ;; (defisland ~name (params) body) + ;; Like defcomp but creates an island (reactive component). + ;; Islands have the same calling convention as components but + ;; render with a reactive context on the client. + (let ((name-sym (first args)) + (params-raw (nth args 1)) + (body (last args)) + (comp-name (strip-prefix (symbol-name name-sym) "~")) + (parsed (parse-comp-params params-raw)) + (params (first parsed)) + (has-children (nth parsed 1))) + (let ((island (make-island comp-name params has-children body env))) + (env-set! env (symbol-name name-sym) island) + island)))) + + +(define sf-defmacro + (fn ((args :as list) (env :as dict)) + (let ((name-sym (first args)) + (params-raw (nth args 1)) + (body (nth args 2)) + (parsed (parse-macro-params params-raw)) + (params (first parsed)) + (rest-param (nth parsed 1))) + (let ((mac (make-macro params rest-param body env (symbol-name name-sym)))) + (env-set! env (symbol-name name-sym) mac) + mac)))) + +(define parse-macro-params + (fn ((params-expr :as list)) + ;; Parse (a b &rest rest) → ((a b) rest) + (let ((params (list)) + (rest-param nil)) + (reduce + (fn (state p) + (if (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) + (assoc state "in-rest" true) + (if (get state "in-rest") + (do (set! rest-param (if (= (type-of p) "symbol") + (symbol-name p) p)) + state) + (do (append! params (if (= (type-of p) "symbol") + (symbol-name p) p)) + state)))) + (dict "in-rest" false) + params-expr) + (list params rest-param)))) + + +(define sf-defstyle + (fn ((args :as list) (env :as dict)) + ;; (defstyle name expr) — bind name to evaluated expr (string, function, etc.) + (let ((name-sym (first args)) + (value (trampoline (eval-expr (nth args 1) env)))) + (env-set! env (symbol-name name-sym) value) + value))) + + +;; -- deftype helpers (must be in eval.sx, not types.sx, because +;; sf-deftype is always compiled but types.sx is a spec module) -- + +(define make-type-def + (fn ((name :as string) (params :as list) body) + {:name name :params params :body body})) + +(define normalize-type-body + (fn (body) + ;; Convert AST type expressions to type representation. + ;; Symbols → strings, (union ...) → (or ...), dict keys → strings. + (cond + (nil? body) "nil" + (= (type-of body) "symbol") + (symbol-name body) + (= (type-of body) "string") + body + (= (type-of body) "keyword") + (keyword-name body) + (= (type-of body) "dict") + ;; Record type — normalize values + (map-dict (fn (k v) (normalize-type-body v)) body) + (= (type-of body) "list") + (if (empty? body) "any" + (let ((head (first body))) + (let ((head-name (if (= (type-of head) "symbol") + (symbol-name head) (str head)))) + ;; (union a b) → (or a b) + (if (= head-name "union") + (cons "or" (map normalize-type-body (rest body))) + ;; (or a b), (list-of t), (-> ...) etc. + (cons head-name (map normalize-type-body (rest body))))))) + :else (str body)))) + +(define sf-deftype + (fn ((args :as list) (env :as dict)) + ;; (deftype name body) or (deftype (name a b ...) body) + (let ((name-or-form (first args)) + (body-expr (nth args 1)) + (type-name nil) + (type-params (list))) + ;; Parse name — symbol or (symbol params...) + (if (= (type-of name-or-form) "symbol") + (set! type-name (symbol-name name-or-form)) + (when (= (type-of name-or-form) "list") + (set! type-name (symbol-name (first name-or-form))) + (set! type-params + (map (fn (p) (if (= (type-of p) "symbol") + (symbol-name p) (str p))) + (rest name-or-form))))) + ;; Normalize and store in *type-registry* + (let ((body (normalize-type-body body-expr)) + (registry (if (env-has? env "*type-registry*") + (env-get env "*type-registry*") + (dict)))) + (dict-set! registry type-name + (make-type-def type-name type-params body)) + (env-set! env "*type-registry*" registry) + nil)))) + + +(define sf-defeffect + (fn ((args :as list) (env :as dict)) + ;; (defeffect name) — register an effect name + (let ((effect-name (if (= (type-of (first args)) "symbol") + (symbol-name (first args)) + (str (first args)))) + (registry (if (env-has? env "*effect-registry*") + (env-get env "*effect-registry*") + (list)))) + (when (not (contains? registry effect-name)) + (append! registry effect-name)) + (env-set! env "*effect-registry*" registry) + nil))) + + +(define sf-begin + (fn ((args :as list) (env :as dict)) + (if (empty? args) + nil + (do + (for-each + (fn (e) (trampoline (eval-expr e env))) + (slice args 0 (dec (len args)))) + (make-thunk (last args) env))))) + + +(define sf-quote + (fn ((args :as list) (env :as dict)) + (if (empty? args) nil (first args)))) + + +(define sf-quasiquote + (fn ((args :as list) (env :as dict)) + (qq-expand (first args) env))) + +(define qq-expand + (fn (template (env :as dict)) + (if (not (= (type-of template) "list")) + template + (if (empty? template) + (list) + (let ((head (first template))) + (if (and (= (type-of head) "symbol") (= (symbol-name head) "unquote")) + (trampoline (eval-expr (nth template 1) env)) + ;; Walk children, handling splice-unquote + (reduce + (fn (result item) + (if (and (= (type-of item) "list") + (= (len item) 2) + (= (type-of (first item)) "symbol") + (= (symbol-name (first item)) "splice-unquote")) + (let ((spliced (trampoline (eval-expr (nth item 1) env)))) + (if (= (type-of spliced) "list") + (concat result spliced) + (if (nil? spliced) result (concat result (list spliced))))) + (concat result (list (qq-expand item env))))) + (list) + template))))))) + + +(define sf-thread-first + (fn ((args :as list) (env :as dict)) + (let ((val (trampoline (eval-expr (first args) env)))) + (reduce + (fn (result form) + (if (= (type-of form) "list") + (let ((f (trampoline (eval-expr (first form) env))) + (rest-args (map (fn (a) (trampoline (eval-expr a env))) + (rest form))) + (all-args (cons result rest-args))) + (cond + (and (callable? f) (not (lambda? f))) + (apply f all-args) + (lambda? f) + (trampoline (call-lambda f all-args env)) + :else (error (str "-> form not callable: " (inspect f))))) + (let ((f (trampoline (eval-expr form env)))) + (cond + (and (callable? f) (not (lambda? f))) + (f result) + (lambda? f) + (trampoline (call-lambda f (list result) env)) + :else (error (str "-> form not callable: " (inspect f))))))) + val + (rest args))))) + + +(define sf-set! + (fn ((args :as list) (env :as dict)) + (let ((name (symbol-name (first args))) + (value (trampoline (eval-expr (nth args 1) env)))) + (env-set! env name value) + value))) + + +;; -------------------------------------------------------------------------- +;; 6c. letrec — mutually recursive local bindings +;; -------------------------------------------------------------------------- +;; +;; (letrec ((even? (fn (n) (if (= n 0) true (odd? (- n 1))))) +;; (odd? (fn (n) (if (= n 0) false (even? (- n 1)))))) +;; (even? 10)) +;; +;; All bindings are first set to nil in the local env, then all values +;; are evaluated (so they can see each other's names), then lambda +;; closures are patched to include the final bindings. +;; -------------------------------------------------------------------------- + +(define sf-letrec + (fn ((args :as list) (env :as dict)) + (let ((bindings (first args)) + (body (rest args)) + (local (env-extend env)) + (names (list)) + (val-exprs (list))) + ;; First pass: bind all names to nil + (if (and (= (type-of (first bindings)) "list") + (= (len (first bindings)) 2)) + ;; Scheme-style + (for-each + (fn (binding) + (let ((vname (if (= (type-of (first binding)) "symbol") + (symbol-name (first binding)) + (first binding)))) + (append! names vname) + (append! val-exprs (nth binding 1)) + (env-set! local vname nil))) + bindings) + ;; Clojure-style + (reduce + (fn (acc pair-idx) + (let ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol") + (symbol-name (nth bindings (* pair-idx 2))) + (nth bindings (* pair-idx 2)))) + (val-expr (nth bindings (inc (* pair-idx 2))))) + (append! names vname) + (append! val-exprs val-expr) + (env-set! local vname nil))) + nil + (range 0 (/ (len bindings) 2)))) + ;; Second pass: evaluate values (they can see each other's names) + (let ((values (map (fn (e) (trampoline (eval-expr e local))) val-exprs))) + ;; Bind final values + (for-each + (fn (pair) (env-set! local (first pair) (nth pair 1))) + (zip names values)) + ;; Patch lambda closures so they see the final bindings + (for-each + (fn (val) + (when (lambda? val) + (for-each + (fn (n) (env-set! (lambda-closure val) n (env-get local n))) + names))) + values)) + ;; Evaluate body + (for-each + (fn (e) (trampoline (eval-expr e local))) + (slice body 0 (dec (len body)))) + (make-thunk (last body) local)))) + + +;; -------------------------------------------------------------------------- +;; 6d. dynamic-wind — entry/exit guards +;; -------------------------------------------------------------------------- +;; +;; (dynamic-wind before-thunk body-thunk after-thunk) +;; +;; All three are zero-argument functions (thunks): +;; 1. Call before-thunk +;; 2. Call body-thunk, capture result +;; 3. Call after-thunk (always, even on error) +;; 4. Return body result +;; +;; The wind stack is maintained so that when continuations jump across +;; dynamic-wind boundaries, the correct before/after thunks fire. +;; Without active continuations, this is equivalent to try/finally. +;; +;; Platform requirements: +;; (push-wind! before after) — push wind record onto stack +;; (pop-wind!) — pop wind record from stack +;; (call-thunk f env) — call a zero-arg function +;; -------------------------------------------------------------------------- + +(define sf-dynamic-wind + (fn ((args :as list) (env :as dict)) + (let ((before (trampoline (eval-expr (first args) env))) + (body (trampoline (eval-expr (nth args 1) env))) + (after (trampoline (eval-expr (nth args 2) env)))) + ;; Delegate to platform — needs try/finally for error safety + (dynamic-wind-call before body after env)))) + + +;; -------------------------------------------------------------------------- +;; 6a2. scope — unified render-time dynamic scope primitive +;; -------------------------------------------------------------------------- +;; +;; (scope name body...) or (scope name :value v body...) +;; Push a named scope with optional value and empty accumulator, +;; evaluate body, pop scope. Returns last body result. +;; +;; `provide` is sugar: (provide name value body...) = (scope name :value value body...) + +(define sf-scope + (fn ((args :as list) (env :as dict)) + (let ((name (trampoline (eval-expr (first args) env))) + (rest (slice args 1)) + (val nil) + (body-exprs nil)) + ;; Check for :value keyword + (if (and (>= (len rest) 2) (= (type-of (first rest)) "keyword") (= (keyword-name (first rest)) "value")) + (do (set! val (trampoline (eval-expr (nth rest 1) env))) + (set! body-exprs (slice rest 2))) + (set! body-exprs rest)) + (scope-push! name val) + (let ((result nil)) + (for-each (fn (e) (set! result (trampoline (eval-expr e env)))) body-exprs) + (scope-pop! name) + result)))) + + +;; provide — sugar for scope with a value +;; (provide name value body...) → (scope name :value value body...) + +(define sf-provide + (fn ((args :as list) (env :as dict)) + (let ((name (trampoline (eval-expr (first args) env))) + (val (trampoline (eval-expr (nth args 1) env))) + (body-exprs (slice args 2)) + (result nil)) + (scope-push! name val) + (for-each (fn (e) (set! result (trampoline (eval-expr e env)))) body-exprs) + (scope-pop! name) + result))) + + +;; -------------------------------------------------------------------------- +;; 6b. Macro expansion +;; -------------------------------------------------------------------------- + +(define expand-macro + (fn ((mac :as macro) (raw-args :as list) (env :as dict)) + (let ((local (env-merge (macro-closure mac) env))) + ;; Bind positional params (unevaluated) + (for-each + (fn (pair) + (env-set! local (first pair) + (if (< (nth pair 1) (len raw-args)) + (nth raw-args (nth pair 1)) + nil))) + (map-indexed (fn (i p) (list p i)) (macro-params mac))) + ;; Bind &rest param + (when (macro-rest-param mac) + (env-set! local (macro-rest-param mac) + (slice raw-args (len (macro-params mac))))) + ;; Evaluate body → new AST + (trampoline (eval-expr (macro-body mac) local))))) + + +;; -------------------------------------------------------------------------- +;; 7. Higher-order forms +;; -------------------------------------------------------------------------- + +;; call-fn: unified caller for HO forms — handles both Lambda and native callable +(define call-fn + (fn (f (args :as list) (env :as dict)) + (cond + (lambda? f) (trampoline (call-lambda f args env)) + (callable? f) (apply f args) + :else (error (str "Not callable in HO form: " (inspect f)))))) + +(define ho-map + (fn ((args :as list) (env :as dict)) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (map (fn (item) (call-fn f (list item) env)) coll)))) + +(define ho-map-indexed + (fn ((args :as list) (env :as dict)) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (map-indexed + (fn (i item) (call-fn f (list i item) env)) + coll)))) + +(define ho-filter + (fn ((args :as list) (env :as dict)) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (filter + (fn (item) (call-fn f (list item) env)) + coll)))) + +(define ho-reduce + (fn ((args :as list) (env :as dict)) + (let ((f (trampoline (eval-expr (first args) env))) + (init (trampoline (eval-expr (nth args 1) env))) + (coll (trampoline (eval-expr (nth args 2) env)))) + (reduce + (fn (acc item) (call-fn f (list acc item) env)) + init + coll)))) + +(define ho-some + (fn ((args :as list) (env :as dict)) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (some + (fn (item) (call-fn f (list item) env)) + coll)))) + +(define ho-every + (fn ((args :as list) (env :as dict)) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (every? + (fn (item) (call-fn f (list item) env)) + coll)))) + + +(define ho-for-each + (fn ((args :as list) (env :as dict)) + (let ((f (trampoline (eval-expr (first args) env))) + (coll (trampoline (eval-expr (nth args 1) env)))) + (for-each + (fn (item) (call-fn f (list item) env)) + coll)))) + + +;; -------------------------------------------------------------------------- +;; 8. Primitives — pure functions available in all targets +;; -------------------------------------------------------------------------- +;; These are the ~80 built-in functions. Each target implements them +;; natively but they MUST have identical semantics. This section serves +;; as the specification — bootstrap compilers use it for reference. +;; +;; Primitives are NOT defined here as SX lambdas (that would be circular). +;; Instead, this is a declarative registry that bootstrap compilers read. +;; -------------------------------------------------------------------------- + +;; See primitives.sx for the full specification. + + +;; -------------------------------------------------------------------------- +;; 9. Platform interface — must be provided by each target +;; -------------------------------------------------------------------------- +;; +;; Type inspection: +;; (type-of x) → "number" | "string" | "boolean" | "nil" +;; | "symbol" | "keyword" | "list" | "dict" +;; | "lambda" | "component" | "macro" | "thunk" +;; | "spread" +;; (symbol-name sym) → string +;; (keyword-name kw) → string +;; +;; Constructors: +;; (make-lambda params body env) → Lambda +;; (make-component name params has-children body env affinity) → Component +;; (make-macro params rest-param body env name) → Macro +;; (make-thunk expr env) → Thunk +;; +;; Accessors: +;; (lambda-params f) → list of strings +;; (lambda-body f) → expr +;; (lambda-closure f) → env +;; (lambda-name f) → string or nil +;; (set-lambda-name! f n) → void +;; (component-params c) → list of strings +;; (component-body c) → expr +;; (component-closure c) → env +;; (component-has-children? c) → boolean +;; (component-affinity c) → "auto" | "client" | "server" +;; +;; (make-island name params has-children body env) → Island +;; (island? x) → boolean +;; ;; Islands reuse component accessors: component-params, component-body, etc. +;; +;; (make-spread attrs) → Spread (attrs dict injected onto parent element) +;; (spread? x) → boolean +;; (spread-attrs s) → dict +;; +;; (macro-params m) → list of strings +;; (macro-rest-param m) → string or nil +;; (macro-body m) → expr +;; (macro-closure m) → env +;; (thunk? x) → boolean +;; (thunk-expr t) → expr +;; (thunk-env t) → env +;; +;; Predicates: +;; (callable? x) → boolean (native function or lambda) +;; (lambda? x) → boolean +;; (component? x) → boolean +;; (island? x) → boolean +;; (macro? x) → boolean +;; (primitive? name) → boolean (is name a registered primitive?) +;; (get-primitive name) → function +;; +;; Environment: +;; (env-has? env name) → boolean +;; (env-get env name) → value +;; (env-set! env name val) → void (mutating) +;; (env-extend env) → new env inheriting from env +;; (env-merge base overlay) → new env with overlay on top +;; +;; Mutation helpers (for parse-keyword-args): +;; (dict-set! d key val) → void +;; (dict-get d key) → value or nil +;; (append! lst val) → void (mutating append) +;; +;; Error: +;; (error msg) → raise/throw with message +;; (inspect x) → string representation for debugging +;; +;; Utility: +;; (strip-prefix s prefix) → string with prefix removed (or s unchanged) +;; (apply f args) → call f with args list +;; (zip lists...) → list of tuples +;; +;; +;; Dynamic wind (for dynamic-wind): +;; (push-wind! before after) → void (push wind record onto stack) +;; (pop-wind!) → void (pop wind record from stack) +;; (call-thunk f env) → value (call a zero-arg function) +;; +;; Render-time accumulators: +;; (collect! bucket value) → void (add to named bucket, deduplicated) +;; (collected bucket) → list (all values in bucket) +;; (clear-collected! bucket) → void (empty the bucket) +;; -------------------------------------------------------------------------- diff --git a/spec/frames.sx b/spec/frames.sx new file mode 100644 index 0000000..05e27c3 --- /dev/null +++ b/spec/frames.sx @@ -0,0 +1,262 @@ +;; ========================================================================== +;; frames.sx — CEK machine frame types +;; +;; Defines the continuation frame types used by the explicit CEK evaluator. +;; Each frame represents a "what to do next" when a sub-evaluation completes. +;; +;; A CEK state is a dict: +;; {:control expr — expression being evaluated (or nil in continue phase) +;; :env env — current environment +;; :kont list — continuation: list of frames (stack, head = top) +;; :phase "eval"|"continue" +;; :value any} — value produced (only in continue phase) +;; +;; Two-phase step function: +;; step-eval: control is expression → dispatch → push frame + new control +;; step-continue: value produced → pop frame → dispatch → new state +;; +;; Terminal state: phase = "continue" and kont is empty → value is final result. +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. CEK State constructors +;; -------------------------------------------------------------------------- + +(define make-cek-state + (fn (control env kont) + {:control control :env env :kont kont :phase "eval" :value nil})) + +(define make-cek-value + (fn (value env kont) + {:control nil :env env :kont kont :phase "continue" :value value})) + +(define cek-terminal? + (fn (state) + (and (= (get state "phase") "continue") + (empty? (get state "kont"))))) + +(define cek-control (fn (s) (get s "control"))) +(define cek-env (fn (s) (get s "env"))) +(define cek-kont (fn (s) (get s "kont"))) +(define cek-phase (fn (s) (get s "phase"))) +(define cek-value (fn (s) (get s "value"))) + + +;; -------------------------------------------------------------------------- +;; 2. Frame constructors +;; -------------------------------------------------------------------------- +;; Each frame type is a dict with a "type" key and frame-specific data. + +;; IfFrame: waiting for condition value +;; After condition evaluates, choose then or else branch +(define make-if-frame + (fn (then-expr else-expr env) + {:type "if" :then then-expr :else else-expr :env env})) + +;; WhenFrame: waiting for condition value +;; If truthy, evaluate body exprs sequentially +(define make-when-frame + (fn (body-exprs env) + {:type "when" :body body-exprs :env env})) + +;; BeginFrame: sequential evaluation +;; Remaining expressions to evaluate after current one +(define make-begin-frame + (fn (remaining env) + {:type "begin" :remaining remaining :env env})) + +;; LetFrame: binding evaluation in progress +;; name = current binding name, remaining = remaining (name val) pairs +;; body = body expressions to evaluate after all bindings +(define make-let-frame + (fn (name remaining body local) + {:type "let" :name name :remaining remaining :body body :env local})) + +;; DefineFrame: waiting for value to bind +(define make-define-frame + (fn (name env has-effects effect-list) + {:type "define" :name name :env env + :has-effects has-effects :effect-list effect-list})) + +;; SetFrame: waiting for value to assign +(define make-set-frame + (fn (name env) + {:type "set" :name name :env env})) + +;; ArgFrame: evaluating function arguments +;; f = function value (already evaluated), evaled = already evaluated args +;; remaining = remaining arg expressions +(define make-arg-frame + (fn (f evaled remaining env raw-args) + {:type "arg" :f f :evaled evaled :remaining remaining :env env + :raw-args raw-args})) + +;; CallFrame: about to call with fully evaluated args +(define make-call-frame + (fn (f args env) + {:type "call" :f f :args args :env env})) + +;; CondFrame: evaluating cond clauses +(define make-cond-frame + (fn (remaining env scheme?) + {:type "cond" :remaining remaining :env env :scheme scheme?})) + +;; CaseFrame: evaluating case clauses +(define make-case-frame + (fn (match-val remaining env) + {:type "case" :match-val match-val :remaining remaining :env env})) + +;; ThreadFirstFrame: pipe threading +(define make-thread-frame + (fn (remaining env) + {:type "thread" :remaining remaining :env env})) + +;; MapFrame: higher-order map/map-indexed in progress +(define make-map-frame + (fn (f remaining results env) + {:type "map" :f f :remaining remaining :results results :env env :indexed false})) + +(define make-map-indexed-frame + (fn (f remaining results env) + {:type "map" :f f :remaining remaining :results results :env env :indexed true})) + +;; FilterFrame: higher-order filter in progress +(define make-filter-frame + (fn (f remaining results current-item env) + {:type "filter" :f f :remaining remaining :results results + :current-item current-item :env env})) + +;; ReduceFrame: higher-order reduce in progress +(define make-reduce-frame + (fn (f remaining env) + {:type "reduce" :f f :remaining remaining :env env})) + +;; ForEachFrame: higher-order for-each in progress +(define make-for-each-frame + (fn (f remaining env) + {:type "for-each" :f f :remaining remaining :env env})) + +;; SomeFrame: higher-order some (short-circuit on first truthy) +(define make-some-frame + (fn (f remaining env) + {:type "some" :f f :remaining remaining :env env})) + +;; EveryFrame: higher-order every? (short-circuit on first falsy) +(define make-every-frame + (fn (f remaining env) + {:type "every" :f f :remaining remaining :env env})) + +;; ScopeFrame: scope-pop! when frame pops +(define make-scope-frame + (fn (name remaining env) + {:type "scope" :name name :remaining remaining :env env})) + +;; ResetFrame: delimiter for shift/reset continuations +(define make-reset-frame + (fn (env) + {:type "reset" :env env})) + +;; DictFrame: evaluating dict values +(define make-dict-frame + (fn (remaining results env) + {:type "dict" :remaining remaining :results results :env env})) + +;; AndFrame: short-circuit and +(define make-and-frame + (fn (remaining env) + {:type "and" :remaining remaining :env env})) + +;; OrFrame: short-circuit or +(define make-or-frame + (fn (remaining env) + {:type "or" :remaining remaining :env env})) + +;; QuasiquoteFrame (not a real frame — QQ is handled specially) + +;; DynamicWindFrame: phases of dynamic-wind +(define make-dynamic-wind-frame + (fn (phase body-thunk after-thunk env) + {:type "dynamic-wind" :phase phase + :body-thunk body-thunk :after-thunk after-thunk :env env})) + +;; ReactiveResetFrame: delimiter for reactive deref-as-shift +;; Carries an update-fn that gets called with new values on re-render. +(define make-reactive-reset-frame + (fn (env update-fn first-render?) + {:type "reactive-reset" :env env :update-fn update-fn + :first-render first-render?})) + +;; DerefFrame: awaiting evaluation of deref's argument +(define make-deref-frame + (fn (env) + {:type "deref" :env env})) + + +;; -------------------------------------------------------------------------- +;; 3. Frame accessors +;; -------------------------------------------------------------------------- + +(define frame-type (fn (f) (get f "type"))) + + +;; -------------------------------------------------------------------------- +;; 4. Continuation operations +;; -------------------------------------------------------------------------- + +(define kont-push + (fn (frame kont) (cons frame kont))) + +(define kont-top + (fn (kont) (first kont))) + +(define kont-pop + (fn (kont) (rest kont))) + +(define kont-empty? + (fn (kont) (empty? kont))) + + +;; -------------------------------------------------------------------------- +;; 5. CEK shift/reset support +;; -------------------------------------------------------------------------- +;; shift captures all frames up to the nearest ResetFrame. +;; reset pushes a ResetFrame. + +(define kont-capture-to-reset + (fn (kont) + ;; Returns (captured-frames remaining-kont). + ;; captured-frames: frames from top up to (not including) ResetFrame. + ;; remaining-kont: frames after ResetFrame. + ;; Stops at either "reset" or "reactive-reset" frames. + (define scan + (fn (k captured) + (if (empty? k) + (error "shift without enclosing reset") + (let ((frame (first k))) + (if (or (= (frame-type frame) "reset") + (= (frame-type frame) "reactive-reset")) + (list captured (rest k)) + (scan (rest k) (append captured (list frame)))))))) + (scan kont (list)))) + +;; Check if a ReactiveResetFrame exists anywhere in the continuation +(define has-reactive-reset-frame? + (fn (kont) + (if (empty? kont) false + (if (= (frame-type (first kont)) "reactive-reset") true + (has-reactive-reset-frame? (rest kont)))))) + +;; Capture frames up to nearest ReactiveResetFrame. +;; Returns (captured-frames, reset-frame, remaining-kont). +(define kont-capture-to-reactive-reset + (fn (kont) + (define scan + (fn (k captured) + (if (empty? k) + (error "reactive deref without enclosing reactive-reset") + (let ((frame (first k))) + (if (= (frame-type frame) "reactive-reset") + (list captured frame (rest k)) + (scan (rest k) (append captured (list frame)))))))) + (scan kont (list)))) diff --git a/spec/parser.sx b/spec/parser.sx new file mode 100644 index 0000000..2fb9b2d --- /dev/null +++ b/spec/parser.sx @@ -0,0 +1,418 @@ +;; ========================================================================== +;; parser.sx — Reference SX parser specification +;; +;; Defines how SX source text is tokenized and parsed into AST. +;; The parser is intentionally simple — s-expressions need minimal parsing. +;; +;; Single-pass recursive descent: reads source text directly into AST, +;; no separate tokenization phase. All mutable cursor state lives inside +;; the parse closure. +;; +;; Grammar: +;; program → expr* +;; expr → atom | list | vector | map | quote-sugar +;; list → '(' expr* ')' +;; vector → '[' expr* ']' (sugar for list) +;; map → '{' (key expr)* '}' +;; atom → string | number | keyword | symbol | boolean | nil +;; string → '"' (char | escape)* '"' +;; number → '-'? digit+ ('.' digit+)? ([eE] [+-]? digit+)? +;; keyword → ':' ident +;; symbol → ident +;; boolean → 'true' | 'false' +;; nil → 'nil' +;; ident → ident-start ident-char* +;; comment → ';' to end of line (discarded) +;; +;; Quote sugar: +;; 'expr → (quote expr) +;; `expr → (quasiquote expr) +;; ,expr → (unquote expr) +;; ,@expr → (splice-unquote expr) +;; +;; Reader macros: +;; #;expr → datum comment (read and discard expr) +;; #|raw chars| → raw string literal (no escape processing) +;; #'expr → (quote expr) +;; #name expr → extensible dispatch (calls registered handler) +;; +;; Platform interface (each target implements natively): +;; (ident-start? ch) → boolean +;; (ident-char? ch) → boolean +;; (make-symbol name) → Symbol value +;; (make-keyword name) → Keyword value +;; (escape-string s) → string with " and \ escaped for serialization +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; Parser — single-pass recursive descent +;; -------------------------------------------------------------------------- +;; Returns a list of top-level AST expressions. + +(define sx-parse :effects [] + (fn ((source :as string)) + (let ((pos 0) + (len-src (len source))) + + ;; -- Cursor helpers (closure over pos, source, len-src) -- + + (define skip-comment :effects [] + (fn () + (when (and (< pos len-src) (not (= (nth source pos) "\n"))) + (set! pos (inc pos)) + (skip-comment)))) + + (define skip-ws :effects [] + (fn () + (when (< pos len-src) + (let ((ch (nth source pos))) + (cond + ;; Whitespace + (or (= ch " ") (= ch "\t") (= ch "\n") (= ch "\r")) + (do (set! pos (inc pos)) (skip-ws)) + ;; Comment — skip to end of line + (= ch ";") + (do (set! pos (inc pos)) + (skip-comment) + (skip-ws)) + ;; Not whitespace or comment — stop + :else nil))))) + + ;; -- Atom readers -- + + (define hex-digit-value :effects [] + (fn (ch) (index-of "0123456789abcdef" (lower ch)))) + + (define read-string :effects [] + (fn () + (set! pos (inc pos)) ;; skip opening " + (let ((buf "")) + (define read-str-loop :effects [] + (fn () + (if (>= pos len-src) + (error "Unterminated string") + (let ((ch (nth source pos))) + (cond + (= ch "\"") + (do (set! pos (inc pos)) nil) ;; done + (= ch "\\") + (do (set! pos (inc pos)) + (let ((esc (nth source pos))) + (if (= esc "u") + ;; Unicode escape: \uXXXX → char + (do (set! pos (inc pos)) + (let ((d0 (hex-digit-value (nth source pos))) + (_ (set! pos (inc pos))) + (d1 (hex-digit-value (nth source pos))) + (_ (set! pos (inc pos))) + (d2 (hex-digit-value (nth source pos))) + (_ (set! pos (inc pos))) + (d3 (hex-digit-value (nth source pos))) + (_ (set! pos (inc pos)))) + (set! buf (str buf (char-from-code + (+ (* d0 4096) (* d1 256) (* d2 16) d3)))) + (read-str-loop))) + ;; Standard escapes: \n \t \r or literal + (do (set! buf (str buf + (cond + (= esc "n") "\n" + (= esc "t") "\t" + (= esc "r") "\r" + :else esc))) + (set! pos (inc pos)) + (read-str-loop))))) + :else + (do (set! buf (str buf ch)) + (set! pos (inc pos)) + (read-str-loop))))))) + (read-str-loop) + buf))) + + (define read-ident :effects [] + (fn () + (let ((start pos)) + (define read-ident-loop :effects [] + (fn () + (when (and (< pos len-src) + (ident-char? (nth source pos))) + (set! pos (inc pos)) + (read-ident-loop)))) + (read-ident-loop) + (slice source start pos)))) + + (define read-keyword :effects [] + (fn () + (set! pos (inc pos)) ;; skip : + (make-keyword (read-ident)))) + + (define read-number :effects [] + (fn () + (let ((start pos)) + ;; Optional leading minus + (when (and (< pos len-src) (= (nth source pos) "-")) + (set! pos (inc pos))) + ;; Integer digits + (define read-digits :effects [] + (fn () + (when (and (< pos len-src) + (let ((c (nth source pos))) + (and (>= c "0") (<= c "9")))) + (set! pos (inc pos)) + (read-digits)))) + (read-digits) + ;; Decimal part + (when (and (< pos len-src) (= (nth source pos) ".")) + (set! pos (inc pos)) + (read-digits)) + ;; Exponent + (when (and (< pos len-src) + (or (= (nth source pos) "e") + (= (nth source pos) "E"))) + (set! pos (inc pos)) + (when (and (< pos len-src) + (or (= (nth source pos) "+") + (= (nth source pos) "-"))) + (set! pos (inc pos))) + (read-digits)) + (parse-number (slice source start pos))))) + + (define read-symbol :effects [] + (fn () + (let ((name (read-ident))) + (cond + (= name "true") true + (= name "false") false + (= name "nil") nil + :else (make-symbol name))))) + + ;; -- Composite readers -- + + (define read-list :effects [] + (fn ((close-ch :as string)) + (let ((items (list))) + (define read-list-loop :effects [] + (fn () + (skip-ws) + (if (>= pos len-src) + (error "Unterminated list") + (if (= (nth source pos) close-ch) + (do (set! pos (inc pos)) nil) ;; done + (do (append! items (read-expr)) + (read-list-loop)))))) + (read-list-loop) + items))) + + (define read-map :effects [] + (fn () + (let ((result (dict))) + (define read-map-loop :effects [] + (fn () + (skip-ws) + (if (>= pos len-src) + (error "Unterminated map") + (if (= (nth source pos) "}") + (do (set! pos (inc pos)) nil) ;; done + (let ((key-expr (read-expr)) + (key-str (if (= (type-of key-expr) "keyword") + (keyword-name key-expr) + (str key-expr))) + (val-expr (read-expr))) + (dict-set! result key-str val-expr) + (read-map-loop)))))) + (read-map-loop) + result))) + + ;; -- Raw string reader (for #|...|) -- + + (define read-raw-string :effects [] + (fn () + (let ((buf "")) + (define raw-loop :effects [] + (fn () + (if (>= pos len-src) + (error "Unterminated raw string") + (let ((ch (nth source pos))) + (if (= ch "|") + (do (set! pos (inc pos)) nil) ;; done + (do (set! buf (str buf ch)) + (set! pos (inc pos)) + (raw-loop))))))) + (raw-loop) + buf))) + + ;; -- Main expression reader -- + + (define read-expr :effects [] + (fn () + (skip-ws) + (if (>= pos len-src) + (error "Unexpected end of input") + (let ((ch (nth source pos))) + (cond + ;; Lists + (= ch "(") + (do (set! pos (inc pos)) (read-list ")")) + (= ch "[") + (do (set! pos (inc pos)) (read-list "]")) + + ;; Map + (= ch "{") + (do (set! pos (inc pos)) (read-map)) + + ;; String + (= ch "\"") + (read-string) + + ;; Keyword + (= ch ":") + (read-keyword) + + ;; Quote sugar + (= ch "'") + (do (set! pos (inc pos)) + (list (make-symbol "quote") (read-expr))) + + ;; Quasiquote sugar + (= ch "`") + (do (set! pos (inc pos)) + (list (make-symbol "quasiquote") (read-expr))) + + ;; Unquote / splice-unquote + (= ch ",") + (do (set! pos (inc pos)) + (if (and (< pos len-src) (= (nth source pos) "@")) + (do (set! pos (inc pos)) + (list (make-symbol "splice-unquote") (read-expr))) + (list (make-symbol "unquote") (read-expr)))) + + ;; Reader macros: # + (= ch "#") + (do (set! pos (inc pos)) + (if (>= pos len-src) + (error "Unexpected end of input after #") + (let ((dispatch-ch (nth source pos))) + (cond + ;; #; — datum comment: read and discard next expr + (= dispatch-ch ";") + (do (set! pos (inc pos)) + (read-expr) ;; read and discard + (read-expr)) ;; return the NEXT expr + + ;; #| — raw string + (= dispatch-ch "|") + (do (set! pos (inc pos)) + (read-raw-string)) + + ;; #' — quote shorthand + (= dispatch-ch "'") + (do (set! pos (inc pos)) + (list (make-symbol "quote") (read-expr))) + + ;; #name — extensible dispatch + (ident-start? dispatch-ch) + (let ((macro-name (read-ident))) + (let ((handler (reader-macro-get macro-name))) + (if handler + (handler (read-expr)) + (error (str "Unknown reader macro: #" macro-name))))) + + :else + (error (str "Unknown reader macro: #" dispatch-ch)))))) + + ;; Number (or negative number) + (or (and (>= ch "0") (<= ch "9")) + (and (= ch "-") + (< (inc pos) len-src) + (let ((next-ch (nth source (inc pos)))) + (and (>= next-ch "0") (<= next-ch "9"))))) + (read-number) + + ;; Ellipsis (... as a symbol) + (and (= ch ".") + (< (+ pos 2) len-src) + (= (nth source (+ pos 1)) ".") + (= (nth source (+ pos 2)) ".")) + (do (set! pos (+ pos 3)) + (make-symbol "...")) + + ;; Symbol (must be ident-start char) + (ident-start? ch) + (read-symbol) + + ;; Unexpected + :else + (error (str "Unexpected character: " ch))))))) + + ;; -- Entry point: parse all top-level expressions -- + (let ((exprs (list))) + (define parse-loop :effects [] + (fn () + (skip-ws) + (when (< pos len-src) + (append! exprs (read-expr)) + (parse-loop)))) + (parse-loop) + exprs)))) + + +;; -------------------------------------------------------------------------- +;; Serializer — AST → SX source text +;; -------------------------------------------------------------------------- + +(define sx-serialize :effects [] + (fn (val) + (case (type-of val) + "nil" "nil" + "boolean" (if val "true" "false") + "number" (str val) + "string" (str "\"" (escape-string val) "\"") + "symbol" (symbol-name val) + "keyword" (str ":" (keyword-name val)) + "list" (str "(" (join " " (map sx-serialize val)) ")") + "dict" (sx-serialize-dict val) + "sx-expr" (sx-expr-source val) + "spread" (str "(make-spread " (sx-serialize-dict (spread-attrs val)) ")") + :else (str val)))) + + +(define sx-serialize-dict :effects [] + (fn ((d :as dict)) + (str "{" + (join " " + (reduce + (fn ((acc :as list) (key :as string)) + (concat acc (list (str ":" key) (sx-serialize (dict-get d key))))) + (list) + (keys d))) + "}"))) + + +;; Alias: adapters use (serialize val) — canonicalize to sx-serialize +(define serialize sx-serialize) + + +;; -------------------------------------------------------------------------- +;; Platform parser interface +;; -------------------------------------------------------------------------- +;; +;; Character classification (implemented natively per target): +;; (ident-start? ch) → boolean +;; True for: a-z A-Z _ ~ * + - > < = / ! ? & +;; +;; (ident-char? ch) → boolean +;; True for: ident-start chars plus: 0-9 . : / # , +;; +;; Constructors (provided by the SX runtime): +;; (make-symbol name) → Symbol value +;; (make-keyword name) → Keyword value +;; (parse-number s) → number (int or float from string) +;; +;; String utilities: +;; (escape-string s) → string with " and \ escaped +;; (sx-expr-source e) → unwrap SxExpr to its source string +;; +;; Reader macro registry: +;; (reader-macro-get name) → handler fn or nil +;; (reader-macro-set! name handler) → register a reader macro +;; -------------------------------------------------------------------------- diff --git a/spec/primitives.sx b/spec/primitives.sx new file mode 100644 index 0000000..ec5a7cb --- /dev/null +++ b/spec/primitives.sx @@ -0,0 +1,607 @@ +;; ========================================================================== +;; primitives.sx — Specification of all SX built-in pure functions +;; +;; Each entry declares: name, parameter signature, and semantics. +;; Bootstrap compilers implement these natively per target. +;; +;; This file is a SPECIFICATION, not executable code. The define-primitive +;; form is a declarative macro that bootstrap compilers consume to generate +;; native primitive registrations. +;; +;; Format: +;; (define-primitive "name" +;; :params (param1 param2 &rest rest) +;; :returns "type" +;; :doc "description" +;; :body (reference-implementation ...)) +;; +;; Typed params use (name :as type) syntax: +;; (define-primitive "+" +;; :params (&rest (args :as number)) +;; :returns "number" +;; :doc "Sum all arguments.") +;; +;; Untyped params default to `any`. Typed params enable the gradual +;; type checker (types.sx) to catch mistyped primitive calls. +;; +;; The :body is optional — when provided, it gives a reference +;; implementation in SX that bootstrap compilers MAY use for testing +;; or as a fallback. Most targets will implement natively for performance. +;; +;; Modules: (define-module :name) scopes subsequent define-primitive +;; entries until the next define-module. Bootstrappers use this to +;; selectively include primitive groups. +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; Core — Arithmetic +;; -------------------------------------------------------------------------- + +(define-module :core.arithmetic) + +(define-primitive "+" + :params (&rest (args :as number)) + :returns "number" + :doc "Sum all arguments." + :body (reduce (fn (a b) (native-add a b)) 0 args)) + +(define-primitive "-" + :params ((a :as number) &rest (b :as number)) + :returns "number" + :doc "Subtract. Unary: negate. Binary: a - b." + :body (if (empty? b) (native-neg a) (native-sub a (first b)))) + +(define-primitive "*" + :params (&rest (args :as number)) + :returns "number" + :doc "Multiply all arguments." + :body (reduce (fn (a b) (native-mul a b)) 1 args)) + +(define-primitive "/" + :params ((a :as number) (b :as number)) + :returns "number" + :doc "Divide a by b." + :body (native-div a b)) + +(define-primitive "mod" + :params ((a :as number) (b :as number)) + :returns "number" + :doc "Modulo a % b." + :body (native-mod a b)) + +(define-primitive "random-int" + :params ((low :as number) (high :as number)) + :returns "number" + :doc "Random integer in [low, high] inclusive." + :body (native-random-int low high)) + +(define-primitive "json-encode" + :params (value) + :returns "string" + :doc "Encode value as JSON string with indentation.") + +(define-primitive "sqrt" + :params ((x :as number)) + :returns "number" + :doc "Square root.") + +(define-primitive "pow" + :params ((x :as number) (n :as number)) + :returns "number" + :doc "x raised to power n.") + +(define-primitive "abs" + :params ((x :as number)) + :returns "number" + :doc "Absolute value.") + +(define-primitive "floor" + :params ((x :as number)) + :returns "number" + :doc "Floor to integer.") + +(define-primitive "ceil" + :params ((x :as number)) + :returns "number" + :doc "Ceiling to integer.") + +(define-primitive "round" + :params ((x :as number) &rest (ndigits :as number)) + :returns "number" + :doc "Round to ndigits decimal places (default 0).") + +(define-primitive "min" + :params (&rest (args :as number)) + :returns "number" + :doc "Minimum. Single list arg or variadic.") + +(define-primitive "max" + :params (&rest (args :as number)) + :returns "number" + :doc "Maximum. Single list arg or variadic.") + +(define-primitive "clamp" + :params ((x :as number) (lo :as number) (hi :as number)) + :returns "number" + :doc "Clamp x to range [lo, hi]." + :body (max lo (min hi x))) + +(define-primitive "inc" + :params ((n :as number)) + :returns "number" + :doc "Increment by 1." + :body (+ n 1)) + +(define-primitive "dec" + :params ((n :as number)) + :returns "number" + :doc "Decrement by 1." + :body (- n 1)) + + +;; -------------------------------------------------------------------------- +;; Core — Comparison +;; -------------------------------------------------------------------------- + +(define-module :core.comparison) + +(define-primitive "=" + :params (a b) + :returns "boolean" + :doc "Deep structural equality. Alias for equal?.") + +(define-primitive "!=" + :params (a b) + :returns "boolean" + :doc "Inequality." + :body (not (= a b))) + +(define-primitive "eq?" + :params (a b) + :returns "boolean" + :doc "Identity equality. True only if a and b are the exact same object. + For immutable atoms (numbers, strings, booleans, nil) this may or + may not match — use eqv? for reliable atom comparison.") + +(define-primitive "eqv?" + :params (a b) + :returns "boolean" + :doc "Equivalent value for atoms, identity for compound objects. + Returns true for identical objects (eq?), and also for numbers, + strings, booleans, and nil with the same value. For lists, dicts, + lambdas, and components, only true if same identity.") + +(define-primitive "equal?" + :params (a b) + :returns "boolean" + :doc "Deep structural equality. Recursively compares lists and dicts. + Same semantics as = but explicit Scheme name.") + +(define-primitive "<" + :params ((a :as number) (b :as number)) + :returns "boolean" + :doc "Less than.") + +(define-primitive ">" + :params ((a :as number) (b :as number)) + :returns "boolean" + :doc "Greater than.") + +(define-primitive "<=" + :params ((a :as number) (b :as number)) + :returns "boolean" + :doc "Less than or equal.") + +(define-primitive ">=" + :params ((a :as number) (b :as number)) + :returns "boolean" + :doc "Greater than or equal.") + + +;; -------------------------------------------------------------------------- +;; Core — Predicates +;; -------------------------------------------------------------------------- + +(define-module :core.predicates) + +(define-primitive "odd?" + :params ((n :as number)) + :returns "boolean" + :doc "True if n is odd." + :body (= (mod n 2) 1)) + +(define-primitive "even?" + :params ((n :as number)) + :returns "boolean" + :doc "True if n is even." + :body (= (mod n 2) 0)) + +(define-primitive "zero?" + :params ((n :as number)) + :returns "boolean" + :doc "True if n is zero." + :body (= n 0)) + +(define-primitive "nil?" + :params (x) + :returns "boolean" + :doc "True if x is nil/null/None.") + +(define-primitive "boolean?" + :params (x) + :returns "boolean" + :doc "True if x is a boolean (true or false). Must be checked before + number? on platforms where booleans are numeric subtypes.") + +(define-primitive "number?" + :params (x) + :returns "boolean" + :doc "True if x is a number (int or float). Excludes booleans.") + +(define-primitive "string?" + :params (x) + :returns "boolean" + :doc "True if x is a string.") + +(define-primitive "list?" + :params (x) + :returns "boolean" + :doc "True if x is a list/array.") + +(define-primitive "dict?" + :params (x) + :returns "boolean" + :doc "True if x is a dict/map.") + +(define-primitive "continuation?" + :params (x) + :returns "boolean" + :doc "True if x is a captured continuation.") + +(define-primitive "empty?" + :params (coll) + :returns "boolean" + :doc "True if coll is nil or has length 0.") + +(define-primitive "contains?" + :params (coll key) + :returns "boolean" + :doc "True if coll contains key. Strings: substring check. Dicts: key check. Lists: membership.") + + +;; -------------------------------------------------------------------------- +;; Core — Logic +;; -------------------------------------------------------------------------- + +(define-module :core.logic) + +(define-primitive "not" + :params (x) + :returns "boolean" + :doc "Logical negation. Note: and/or are special forms (short-circuit).") + + +;; -------------------------------------------------------------------------- +;; Core — Strings +;; -------------------------------------------------------------------------- + +(define-module :core.strings) + +(define-primitive "str" + :params (&rest args) + :returns "string" + :doc "Concatenate all args as strings. nil → empty string, bool → true/false.") + +(define-primitive "concat" + :params (&rest (colls :as list)) + :returns "list" + :doc "Concatenate multiple lists into one. Skips nil values.") + +(define-primitive "upper" + :params ((s :as string)) + :returns "string" + :doc "Uppercase string.") + +(define-primitive "upcase" + :params ((s :as string)) + :returns "string" + :doc "Alias for upper. Uppercase string.") + +(define-primitive "lower" + :params ((s :as string)) + :returns "string" + :doc "Lowercase string.") + +(define-primitive "downcase" + :params ((s :as string)) + :returns "string" + :doc "Alias for lower. Lowercase string.") + +(define-primitive "string-length" + :params ((s :as string)) + :returns "number" + :doc "Length of string in characters.") + +(define-primitive "char-from-code" + :params ((n :as number)) + :returns "string" + :doc "Convert Unicode code point to single-character string.") + +(define-primitive "substring" + :params ((s :as string) (start :as number) (end :as number)) + :returns "string" + :doc "Extract substring from start (inclusive) to end (exclusive).") + +(define-primitive "string-contains?" + :params ((s :as string) (needle :as string)) + :returns "boolean" + :doc "True if string s contains substring needle.") + +(define-primitive "trim" + :params ((s :as string)) + :returns "string" + :doc "Strip leading/trailing whitespace.") + +(define-primitive "split" + :params ((s :as string) &rest (sep :as string)) + :returns "list" + :doc "Split string by separator (default space).") + +(define-primitive "join" + :params ((sep :as string) (coll :as list)) + :returns "string" + :doc "Join collection items with separator string.") + +(define-primitive "replace" + :params ((s :as string) (old :as string) (new :as string)) + :returns "string" + :doc "Replace all occurrences of old with new in s.") + +(define-primitive "slice" + :params (coll (start :as number) &rest (end :as number)) + :returns "any" + :doc "Slice a string or list from start to end (exclusive). End is optional.") + +(define-primitive "index-of" + :params ((s :as string) (needle :as string) &rest (from :as number)) + :returns "number" + :doc "Index of first occurrence of needle in s, or -1 if not found. Optional start index.") + +(define-primitive "starts-with?" + :params ((s :as string) (prefix :as string)) + :returns "boolean" + :doc "True if string s starts with prefix.") + +(define-primitive "ends-with?" + :params ((s :as string) (suffix :as string)) + :returns "boolean" + :doc "True if string s ends with suffix.") + + +;; -------------------------------------------------------------------------- +;; Core — Collections +;; -------------------------------------------------------------------------- + +(define-module :core.collections) + +(define-primitive "list" + :params (&rest args) + :returns "list" + :doc "Create a list from arguments.") + +(define-primitive "dict" + :params (&rest pairs) + :returns "dict" + :doc "Create a dict from key/value pairs: (dict :a 1 :b 2).") + +(define-primitive "range" + :params ((start :as number) (end :as number) &rest (step :as number)) + :returns "list" + :doc "Integer range [start, end) with optional step.") + +(define-primitive "get" + :params (coll key &rest default) + :returns "any" + :doc "Get value from dict by key, or list by index. Optional default.") + +(define-primitive "len" + :params (coll) + :returns "number" + :doc "Length of string, list, or dict.") + +(define-primitive "first" + :params ((coll :as list)) + :returns "any" + :doc "First element, or nil if empty.") + +(define-primitive "last" + :params ((coll :as list)) + :returns "any" + :doc "Last element, or nil if empty.") + +(define-primitive "rest" + :params ((coll :as list)) + :returns "list" + :doc "All elements except the first.") + +(define-primitive "nth" + :params ((coll :as list) (n :as number)) + :returns "any" + :doc "Element at index n, or nil if out of bounds.") + +(define-primitive "cons" + :params (x (coll :as list)) + :returns "list" + :doc "Prepend x to coll.") + +(define-primitive "append" + :params ((coll :as list) x) + :returns "list" + :doc "If x is a list, concatenate. Otherwise append x as single element.") + +(define-primitive "append!" + :params ((coll :as list) x) + :returns "list" + :doc "Mutate coll by appending x in-place. Returns coll.") + +(define-primitive "reverse" + :params ((coll :as list)) + :returns "list" + :doc "Return coll in reverse order.") + +(define-primitive "flatten" + :params ((coll :as list)) + :returns "list" + :doc "Flatten one level of nesting. Nested lists become top-level elements.") + +(define-primitive "chunk-every" + :params ((coll :as list) (n :as number)) + :returns "list" + :doc "Split coll into sub-lists of size n.") + +(define-primitive "zip-pairs" + :params ((coll :as list)) + :returns "list" + :doc "Consecutive pairs: (1 2 3 4) → ((1 2) (2 3) (3 4)).") + + +;; -------------------------------------------------------------------------- +;; Core — Dict operations +;; -------------------------------------------------------------------------- + +(define-module :core.dict) + +(define-primitive "keys" + :params ((d :as dict)) + :returns "list" + :doc "List of dict keys.") + +(define-primitive "vals" + :params ((d :as dict)) + :returns "list" + :doc "List of dict values.") + +(define-primitive "merge" + :params (&rest (dicts :as dict)) + :returns "dict" + :doc "Merge dicts left to right. Later keys win. Skips nil.") + +(define-primitive "has-key?" + :params ((d :as dict) key) + :returns "boolean" + :doc "True if dict d contains key.") + +(define-primitive "assoc" + :params ((d :as dict) &rest pairs) + :returns "dict" + :doc "Return new dict with key/value pairs added/overwritten.") + +(define-primitive "dissoc" + :params ((d :as dict) &rest keys) + :returns "dict" + :doc "Return new dict with keys removed.") + +(define-primitive "dict-set!" + :params ((d :as dict) key val) + :returns "any" + :doc "Mutate dict d by setting key to val in-place. Returns val.") + +(define-primitive "into" + :params (target coll) + :returns "any" + :doc "Pour coll into target. List target: convert to list. Dict target: convert pairs to dict.") + + +;; -------------------------------------------------------------------------- +;; Stdlib — Format +;; -------------------------------------------------------------------------- + +(define-module :stdlib.format) + +(define-primitive "format-date" + :params ((date-str :as string) (fmt :as string)) + :returns "string" + :doc "Parse ISO date string and format with strftime-style format.") + +(define-primitive "format-decimal" + :params ((val :as number) &rest (places :as number)) + :returns "string" + :doc "Format number with fixed decimal places (default 2).") + +(define-primitive "parse-int" + :params (val &rest default) + :returns "number" + :doc "Parse string to integer with optional default on failure.") + +(define-primitive "parse-datetime" + :params ((s :as string)) + :returns "string" + :doc "Parse datetime string — identity passthrough (returns string or nil).") + + +;; -------------------------------------------------------------------------- +;; Stdlib — Text +;; -------------------------------------------------------------------------- + +(define-module :stdlib.text) + +(define-primitive "pluralize" + :params ((count :as number) &rest (forms :as string)) + :returns "string" + :doc "Pluralize: (pluralize 1) → \"\", (pluralize 2) → \"s\". Or (pluralize n \"item\" \"items\").") + +(define-primitive "escape" + :params ((s :as string)) + :returns "string" + :doc "HTML-escape a string (&, <, >, \", ').") + +(define-primitive "strip-tags" + :params ((s :as string)) + :returns "string" + :doc "Remove HTML tags from string.") + + +;; -------------------------------------------------------------------------- +;; Stdlib — Style +;; -------------------------------------------------------------------------- + + + +;; -------------------------------------------------------------------------- +;; Stdlib — Debug +;; -------------------------------------------------------------------------- + +(define-module :stdlib.debug) + +(define-primitive "assert" + :params (condition &rest message) + :returns "boolean" + :doc "Assert condition is truthy; raise error with message if not.") + + +;; -------------------------------------------------------------------------- +;; Type introspection — platform primitives +;; -------------------------------------------------------------------------- + +(define-module :stdlib.types) + +(define-primitive "type-of" + :params (x) + :returns "string" + :doc "Return type name: number, string, boolean, nil, symbol, keyword, list, dict, lambda, component, island, macro.") + +(define-primitive "symbol-name" + :params ((sym :as symbol)) + :returns "string" + :doc "Return the name string of a symbol.") + +(define-primitive "keyword-name" + :params ((kw :as keyword)) + :returns "string" + :doc "Return the name string of a keyword.") + +(define-primitive "sx-parse" + :params ((source :as string)) + :returns "list" + :doc "Parse SX source string into a list of AST expressions.") diff --git a/spec/render.sx b/spec/render.sx new file mode 100644 index 0000000..0293da5 --- /dev/null +++ b/spec/render.sx @@ -0,0 +1,283 @@ +;; ========================================================================== +;; render.sx — Core rendering specification +;; +;; Shared registries and utilities used by all rendering adapters. +;; This file defines WHAT is renderable (tag registries, attribute rules) +;; and HOW arguments are parsed — but not the output format. +;; +;; Adapters: +;; adapter-html.sx — HTML string output (server) +;; adapter-sx.sx — SX wire format output (server → client) +;; adapter-dom.sx — Live DOM node output (browser) +;; +;; Each adapter imports these shared definitions and provides its own +;; render entry point (render-to-html, render-to-sx, render-to-dom). +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; HTML tag registry +;; -------------------------------------------------------------------------- +;; Tags known to the renderer. Unknown names are treated as function calls. +;; Void elements self-close (no children). Boolean attrs emit name only. + +(define HTML_TAGS + (list + ;; Document + "html" "head" "body" "title" "meta" "link" "script" "style" "noscript" + ;; Sections + "header" "nav" "main" "section" "article" "aside" "footer" + "h1" "h2" "h3" "h4" "h5" "h6" "hgroup" + ;; Block + "div" "p" "blockquote" "pre" "figure" "figcaption" "address" "details" "summary" + ;; Inline + "a" "span" "em" "strong" "small" "b" "i" "u" "s" "mark" "sub" "sup" + "abbr" "cite" "code" "time" "br" "wbr" "hr" + ;; Lists + "ul" "ol" "li" "dl" "dt" "dd" + ;; Tables + "table" "thead" "tbody" "tfoot" "tr" "th" "td" "caption" "colgroup" "col" + ;; Forms + "form" "input" "textarea" "select" "option" "optgroup" "button" "label" + "fieldset" "legend" "output" "datalist" + ;; Media + "img" "video" "audio" "source" "picture" "canvas" "iframe" + ;; SVG + "svg" "math" "path" "circle" "ellipse" "rect" "line" "polyline" "polygon" + "text" "tspan" "g" "defs" "use" "clipPath" "mask" "pattern" + "linearGradient" "radialGradient" "stop" "filter" + "feGaussianBlur" "feOffset" "feBlend" "feColorMatrix" "feComposite" + "feMerge" "feMergeNode" "feTurbulence" + "feComponentTransfer" "feFuncR" "feFuncG" "feFuncB" "feFuncA" + "feDisplacementMap" "feFlood" "feImage" "feMorphology" + "feSpecularLighting" "feDiffuseLighting" + "fePointLight" "feSpotLight" "feDistantLight" + "animate" "animateTransform" "foreignObject" + ;; Other + "template" "slot" "dialog" "menu")) + +(define VOID_ELEMENTS + (list "area" "base" "br" "col" "embed" "hr" "img" "input" + "link" "meta" "param" "source" "track" "wbr")) + +(define BOOLEAN_ATTRS + (list "async" "autofocus" "autoplay" "checked" "controls" "default" + "defer" "disabled" "formnovalidate" "hidden" "inert" "ismap" + "loop" "multiple" "muted" "nomodule" "novalidate" "open" + "playsinline" "readonly" "required" "reversed" "selected")) + + +;; -------------------------------------------------------------------------- +;; Shared utilities +;; -------------------------------------------------------------------------- + +(define definition-form? :effects [] + (fn ((name :as string)) + (or (= name "define") (= name "defcomp") (= name "defisland") + (= name "defmacro") (= name "defstyle") (= name "defhandler") + (= name "deftype") (= name "defeffect")))) + + +(define parse-element-args :effects [render] + (fn ((args :as list) (env :as dict)) + ;; Parse (:key val :key2 val2 child1 child2) into (attrs-dict children-list) + (let ((attrs (dict)) + (children (list))) + (reduce + (fn ((state :as dict) arg) + (let ((skip (get state "skip"))) + (if skip + (assoc state "skip" false "i" (inc (get state "i"))) + (if (and (= (type-of arg) "keyword") + (< (inc (get state "i")) (len args))) + (let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) + (dict-set! attrs (keyword-name arg) val) + (assoc state "skip" true "i" (inc (get state "i")))) + (do + (append! children arg) + (assoc state "i" (inc (get state "i")))))))) + (dict "i" 0 "skip" false) + args) + (list attrs children)))) + + +(define render-attrs :effects [] + (fn ((attrs :as dict)) + ;; Render an attrs dict to an HTML attribute string. + ;; Used by adapter-html.sx and adapter-sx.sx. + (join "" + (map + (fn ((key :as string)) + (let ((val (dict-get attrs key))) + (cond + ;; Boolean attrs + (and (contains? BOOLEAN_ATTRS key) val) + (str " " key) + (and (contains? BOOLEAN_ATTRS key) (not val)) + "" + ;; Nil values — skip + (nil? val) "" + ;; Normal attr + :else (str " " key "=\"" (escape-attr (str val)) "\"")))) + (keys attrs))))) + + +;; -------------------------------------------------------------------------- +;; Render adapter helpers +;; -------------------------------------------------------------------------- +;; Shared by HTML and DOM adapters for evaluating control forms during +;; rendering. Unlike sf-cond (eval.sx) which returns a thunk for TCO, +;; eval-cond returns the unevaluated body expression so the adapter +;; can render it in its own mode (HTML string vs DOM nodes). + +;; eval-cond: find matching cond branch, return unevaluated body expr. +;; Handles both scheme-style ((test body) ...) and clojure-style +;; (test body test body ...). +(define eval-cond :effects [] + (fn ((clauses :as list) (env :as dict)) + (if (cond-scheme? clauses) + (eval-cond-scheme clauses env) + (eval-cond-clojure clauses env)))) + +(define eval-cond-scheme :effects [] + (fn ((clauses :as list) (env :as dict)) + (if (empty? clauses) + nil + (let ((clause (first clauses)) + (test (first clause)) + (body (nth clause 1))) + (if (or (and (= (type-of test) "symbol") + (or (= (symbol-name test) "else") + (= (symbol-name test) ":else"))) + (and (= (type-of test) "keyword") + (= (keyword-name test) "else"))) + body + (if (trampoline (eval-expr test env)) + body + (eval-cond-scheme (rest clauses) env))))))) + +(define eval-cond-clojure :effects [] + (fn ((clauses :as list) (env :as dict)) + (if (< (len clauses) 2) + nil + (let ((test (first clauses)) + (body (nth clauses 1))) + (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) + (and (= (type-of test) "symbol") + (or (= (symbol-name test) "else") + (= (symbol-name test) ":else")))) + body + (if (trampoline (eval-expr test env)) + body + (eval-cond-clojure (slice clauses 2) env))))))) + +;; process-bindings: evaluate let-binding pairs, return extended env. +;; bindings = ((name1 expr1) (name2 expr2) ...) +(define process-bindings :effects [mutation] + (fn ((bindings :as list) (env :as dict)) + ;; env-extend (not merge) — Env is not a dict subclass, so merge() + ;; returns an empty dict, losing all parent scope bindings. + (let ((local (env-extend env))) + (for-each + (fn ((pair :as list)) + (when (and (= (type-of pair) "list") (>= (len pair) 2)) + (let ((name (if (= (type-of (first pair)) "symbol") + (symbol-name (first pair)) + (str (first pair))))) + (env-set! local name (trampoline (eval-expr (nth pair 1) local)))))) + bindings) + local))) + + +;; -------------------------------------------------------------------------- +;; is-render-expr? — check if expression is a rendering form +;; -------------------------------------------------------------------------- +;; Used by eval-list to dispatch rendering forms to the active adapter +;; (HTML, SX wire, or DOM) rather than evaluating them as function calls. + +(define is-render-expr? :effects [] + (fn (expr) + (if (or (not (= (type-of expr) "list")) (empty? expr)) + false + (let ((h (first expr))) + (if (not (= (type-of h) "symbol")) + false + (let ((n (symbol-name h))) + (or (= n "<>") + (= n "raw!") + (starts-with? n "~") + (starts-with? n "html:") + (contains? HTML_TAGS n) + (and (> (index-of n "-") 0) + (> (len expr) 1) + (= (type-of (nth expr 1)) "keyword"))))))))) + + +;; -------------------------------------------------------------------------- +;; Spread — attribute injection from children into parent elements +;; -------------------------------------------------------------------------- +;; +;; A spread value is a dict of attributes that, when returned as a child +;; of an HTML element, merges its attrs onto the parent element. +;; This enables components to inject classes/styles/data-attrs onto their +;; parent without the parent knowing about the specific attrs. +;; +;; merge-spread-attrs: merge a spread's attrs into an element's attrs dict. +;; Class values are joined (space-separated); others overwrite. +;; Mutates the target attrs dict in place. + +(define merge-spread-attrs :effects [mutation] + (fn ((target :as dict) (spread-dict :as dict)) + (for-each + (fn ((key :as string)) + (let ((val (dict-get spread-dict key))) + (if (= key "class") + ;; Class: join existing + new with space + (let ((existing (dict-get target "class"))) + (dict-set! target "class" + (if (and existing (not (= existing ""))) + (str existing " " val) + val))) + ;; Style: join with semicolons + (if (= key "style") + (let ((existing (dict-get target "style"))) + (dict-set! target "style" + (if (and existing (not (= existing ""))) + (str existing ";" val) + val))) + ;; Everything else: overwrite + (dict-set! target key val))))) + (keys spread-dict)))) + + +;; -------------------------------------------------------------------------- +;; Platform interface (shared across adapters) +;; -------------------------------------------------------------------------- +;; +;; HTML/attribute escaping (used by HTML and SX wire adapters): +;; (escape-html s) → HTML-escaped string +;; (escape-attr s) → attribute-value-escaped string +;; (raw-html-content r) → unwrap RawHTML marker to string +;; +;; Spread (render-time attribute injection): +;; (make-spread attrs) → Spread value +;; (spread? x) → boolean +;; (spread-attrs s) → dict +;; +;; Render-time accumulators: +;; (collect! bucket value) → void +;; (collected bucket) → list +;; (clear-collected! bucket) → void +;; +;; Scoped effects (scope/provide/context/emit!): +;; (scope-push! name val) → void (general form) +;; (scope-pop! name) → void (general form) +;; (provide-push! name val) → alias for scope-push! +;; (provide-pop! name) → alias for scope-pop! +;; (context name &rest def) → value from nearest scope +;; (emit! name value) → void (append to scope accumulator) +;; (emitted name) → list of emitted values +;; +;; From parser.sx: +;; (sx-serialize val) → SX source string (aliased as serialize above) +;; -------------------------------------------------------------------------- diff --git a/spec/special-forms.sx b/spec/special-forms.sx new file mode 100644 index 0000000..8c880af --- /dev/null +++ b/spec/special-forms.sx @@ -0,0 +1,444 @@ +;; ========================================================================== +;; special-forms.sx — Specification of all SX special forms +;; +;; Special forms are syntactic constructs whose arguments are NOT evaluated +;; before dispatch. Each form has its own evaluation rules — unlike primitives, +;; which receive pre-evaluated values. +;; +;; This file is a SPECIFICATION, not executable code. Bootstrap compilers +;; consume these declarations but implement special forms natively. +;; +;; Format: +;; (define-special-form "name" +;; :syntax (name arg1 arg2 ...) +;; :doc "description" +;; :tail-position "which subexpressions are in tail position" +;; :example "(name ...)") +;; +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; Control flow +;; -------------------------------------------------------------------------- + +(define-special-form "if" + :syntax (if condition then-expr else-expr) + :doc "If condition is truthy, evaluate then-expr; otherwise evaluate else-expr. + Both branches are in tail position. The else branch is optional and + defaults to nil." + :tail-position "then-expr, else-expr" + :example "(if (> x 10) \"big\" \"small\")") + +(define-special-form "when" + :syntax (when condition body ...) + :doc "If condition is truthy, evaluate all body expressions sequentially. + Returns the value of the last body expression, or nil if condition + is falsy. Only the last body expression is in tail position." + :tail-position "last body expression" + :example "(when (logged-in? user) + (render-dashboard user))") + +(define-special-form "cond" + :syntax (cond test1 result1 test2 result2 ... :else default) + :doc "Multi-way conditional. Tests are evaluated in order; the result + paired with the first truthy test is returned. The :else keyword + (or the symbol else) matches unconditionally. Supports both + Clojure-style flat pairs and Scheme-style nested pairs: + Clojure: (cond test1 result1 test2 result2 :else default) + Scheme: (cond (test1 result1) (test2 result2) (else default))" + :tail-position "all result expressions" + :example "(cond + (= status \"active\") (render-active item) + (= status \"draft\") (render-draft item) + :else (render-unknown item))") + +(define-special-form "case" + :syntax (case expr val1 result1 val2 result2 ... :else default) + :doc "Match expr against values using equality. Like cond but tests + a single expression against multiple values. The :else keyword + matches if no values match." + :tail-position "all result expressions" + :example "(case (get request \"method\") + \"GET\" (handle-get request) + \"POST\" (handle-post request) + :else (method-not-allowed))") + +(define-special-form "and" + :syntax (and expr ...) + :doc "Short-circuit logical AND. Evaluates expressions left to right. + Returns the first falsy value, or the last value if all are truthy. + Returns true if given no arguments." + :tail-position "last expression" + :example "(and (valid? input) (authorized? user) (process input))") + +(define-special-form "or" + :syntax (or expr ...) + :doc "Short-circuit logical OR. Evaluates expressions left to right. + Returns the first truthy value, or the last value if all are falsy. + Returns false if given no arguments." + :tail-position "last expression" + :example "(or (get cache key) (fetch-from-db key) \"default\")") + + +;; -------------------------------------------------------------------------- +;; Binding +;; -------------------------------------------------------------------------- + +(define-special-form "let" + :syntax (let bindings body ...) + :doc "Create local bindings and evaluate body in the extended environment. + Bindings can be Scheme-style ((name val) ...) or Clojure-style + (name val name val ...). Each binding can see previous bindings. + Only the last body expression is in tail position. + + Named let: (let name ((x init) ...) body) creates a loop. The name + is bound to a function that takes the same params and recurses with + tail-call optimization." + :tail-position "last body expression; recursive call in named let" + :example ";; Basic let +(let ((x 10) (y 20)) + (+ x y)) + +;; Clojure-style +(let (x 10 y 20) + (+ x y)) + +;; Named let (loop) +(let loop ((i 0) (acc 0)) + (if (= i 100) + acc + (loop (+ i 1) (+ acc i))))") + +(define-special-form "let*" + :syntax (let* bindings body ...) + :doc "Alias for let. In SX, let is already sequential (each binding + sees previous ones), so let* is identical to let." + :tail-position "last body expression" + :example "(let* ((x 10) (y (* x 2))) + (+ x y)) ;; → 30") + +(define-special-form "letrec" + :syntax (letrec bindings body ...) + :doc "Mutually recursive local bindings. All names are bound to nil first, + then all values are evaluated (so they can reference each other), + then lambda closures are patched to include the final bindings. + Used for defining mutually recursive local functions." + :tail-position "last body expression" + :example "(letrec ((even? (fn (n) (if (= n 0) true (odd? (- n 1))))) + (odd? (fn (n) (if (= n 0) false (even? (- n 1)))))) + (even? 10)) ;; → true") + +(define-special-form "define" + :syntax (define name value) + :doc "Bind name to value in the current environment. If value is a lambda + and has no name, the lambda's name is set to the symbol name. + Returns the value." + :tail-position "none (value is eagerly evaluated)" + :example "(define greeting \"hello\") +(define double (fn (x) (* x 2)))") + +(define-special-form "set!" + :syntax (set! name value) + :doc "Mutate an existing binding. The name must already be bound in the + current environment. Returns the new value." + :tail-position "none (value is eagerly evaluated)" + :example "(let (count 0) + (set! count (+ count 1)))") + + +;; -------------------------------------------------------------------------- +;; Functions and components +;; -------------------------------------------------------------------------- + +(define-special-form "lambda" + :syntax (lambda params body) + :doc "Create a function. Params is a list of parameter names. Body is + a single expression (the return value). The lambda captures the + current environment as its closure." + :tail-position "body" + :example "(lambda (x y) (+ x y))") + +(define-special-form "fn" + :syntax (fn params body) + :doc "Alias for lambda." + :tail-position "body" + :example "(fn (x) (* x x))") + +(define-special-form "defcomp" + :syntax (defcomp ~name (&key param1 param2 &rest children) body) + :doc "Define a component. Components are called with keyword arguments + and optional positional children. The &key marker introduces + keyword parameters. The &rest (or &children) marker captures + remaining positional arguments as a list. + + Component names conventionally start with ~ to distinguish them + from HTML elements. Components are evaluated with a merged + environment: closure + caller-env + bound-params." + :tail-position "body" + :example "(defcomp ~card (&key title subtitle &rest children) + (div :class \"card\" + (h2 title) + (when subtitle (p subtitle)) + children))") + +(define-special-form "defisland" + :syntax (defisland ~name (&key param1 param2 &rest children) body) + :doc "Define a reactive island. Islands have the same calling convention + as components (defcomp) but create a reactive boundary. Inside an + island, signals are tracked — deref subscribes DOM nodes to signals, + and signal changes update only the affected nodes. + + On the server, islands render as static HTML wrapped in a + data-sx-island container with serialized initial state. On the + client, islands hydrate into reactive contexts." + :tail-position "body" + :example "(defisland ~counter (&key initial) + (let ((count (signal (or initial 0)))) + (div :class \"counter\" + (span (deref count)) + (button :on-click (fn (e) (swap! count inc)) \"+\"))))") + +(define-special-form "defmacro" + :syntax (defmacro name (params ...) body) + :doc "Define a macro. Macros receive their arguments unevaluated (as raw + AST) and return a new expression that is then evaluated. The + returned expression replaces the macro call. Use quasiquote for + template construction." + :tail-position "none (expansion is evaluated separately)" + :example "(defmacro unless (condition &rest body) + `(when (not ~condition) ~@body))") + +(define-special-form "deftype" + :syntax (deftype name body) + :doc "Define a named type. The name can be a simple symbol for type aliases + and records, or a list (name param ...) for parameterized types. + Body is a type expression: a symbol (alias), (union t1 t2 ...) for + union types, or {:field1 type1 :field2 type2} for record types. + Type definitions are metadata for the type checker with no runtime cost." + :tail-position "none" + :example "(deftype price number) +(deftype card-props {:title string :price number}) +(deftype (maybe a) (union a nil))") + +(define-special-form "defeffect" + :syntax (defeffect name) + :doc "Declare a named effect. Effects annotate functions and components + to track side effects. A pure function (:effects [pure]) cannot + call IO functions. Unannotated functions are assumed to have all + effects. Effect checking is gradual — annotations opt in." + :tail-position "none" + :example "(defeffect io) +(defeffect async) +(define add :effects [pure] (fn (a b) (+ a b)))") + + +;; -------------------------------------------------------------------------- +;; Sequencing and threading +;; -------------------------------------------------------------------------- + +(define-special-form "begin" + :syntax (begin expr ...) + :doc "Evaluate expressions sequentially. Returns the value of the last + expression. Used when multiple side-effecting expressions need + to be grouped." + :tail-position "last expression" + :example "(begin + (log \"starting\") + (process data) + (log \"done\"))") + +(define-special-form "do" + :syntax (do expr ...) + :doc "Alias for begin." + :tail-position "last expression" + :example "(do (set! x 1) (set! y 2) (+ x y))") + +(define-special-form "->" + :syntax (-> value form1 form2 ...) + :doc "Thread-first macro. Threads value through a series of function calls, + inserting it as the first argument of each form. Nested lists are + treated as function calls; bare symbols become unary calls." + :tail-position "last form" + :example "(-> user + (get \"name\") + upper + (str \" says hello\")) +;; Expands to: (str (upper (get user \"name\")) \" says hello\")") + + +;; -------------------------------------------------------------------------- +;; Quoting +;; -------------------------------------------------------------------------- + +(define-special-form "quote" + :syntax (quote expr) + :doc "Return expr as data, without evaluating it. Symbols remain symbols, + lists remain lists. The reader shorthand is the ' prefix." + :tail-position "none (not evaluated)" + :example "'(+ 1 2) ;; → the list (+ 1 2), not the number 3") + +(define-special-form "quasiquote" + :syntax (quasiquote expr) + :doc "Template construction. Like quote, but allows unquoting with ~ and + splicing with ~@. The reader shorthand is the ` prefix. + `(a ~b ~@c) + Quotes everything except: ~expr evaluates expr and inserts the + result; ~@expr evaluates to a list and splices its elements." + :tail-position "none (template is constructed, not evaluated)" + :example "`(div :class \"card\" ~title ~@children)") + + +;; -------------------------------------------------------------------------- +;; Continuations +;; -------------------------------------------------------------------------- + +(define-special-form "reset" + :syntax (reset body) + :doc "Establish a continuation delimiter. Evaluates body normally unless + a shift is encountered, in which case the continuation (the rest + of the computation up to this reset) is captured and passed to + the shift's body. Without shift, reset is a no-op wrapper." + :tail-position "body" + :example "(reset (+ 1 (shift k (k 10)))) ;; → 11") + +(define-special-form "shift" + :syntax (shift k body) + :doc "Capture the continuation to the nearest reset as k, then evaluate + body with k bound. If k is never called, the value of body is + returned from the reset (abort). If k is called with a value, + the reset body is re-evaluated with shift returning that value. + k can be called multiple times." + :tail-position "body" + :example ";; Abort: shift body becomes the reset result +(reset (+ 1 (shift k 42))) ;; → 42 + +;; Resume: k re-enters the computation +(reset (+ 1 (shift k (k 10)))) ;; → 11 + +;; Multiple invocations +(reset (* 2 (shift k (+ (k 1) (k 10))))) ;; → 24") + + +;; -------------------------------------------------------------------------- +;; Guards +;; -------------------------------------------------------------------------- + +(define-special-form "dynamic-wind" + :syntax (dynamic-wind before-thunk body-thunk after-thunk) + :doc "Entry/exit guards. All three arguments are zero-argument functions + (thunks). before-thunk is called on entry, body-thunk is called + for the result, and after-thunk is always called on exit (even on + error). The wind stack is maintained so that when continuations + jump across dynamic-wind boundaries, the correct before/after + thunks fire." + :tail-position "none (all thunks are eagerly called)" + :example "(dynamic-wind + (fn () (log \"entering\")) + (fn () (do-work)) + (fn () (log \"exiting\")))") + + +;; -------------------------------------------------------------------------- +;; Higher-order forms +;; +;; These are syntactic forms (not primitives) because the evaluator +;; handles them directly for performance — avoiding the overhead of +;; constructing argument lists and doing generic dispatch. They could +;; be implemented as primitives but are special-cased in eval-list. +;; -------------------------------------------------------------------------- + +(define-special-form "map" + :syntax (map fn coll) + :doc "Apply fn to each element of coll, returning a list of results." + :tail-position "none" + :example "(map (fn (x) (* x x)) (list 1 2 3 4)) ;; → (1 4 9 16)") + +(define-special-form "map-indexed" + :syntax (map-indexed fn coll) + :doc "Like map, but fn receives two arguments: (index element)." + :tail-position "none" + :example "(map-indexed (fn (i x) (str i \": \" x)) (list \"a\" \"b\" \"c\"))") + +(define-special-form "filter" + :syntax (filter fn coll) + :doc "Return elements of coll for which fn returns truthy." + :tail-position "none" + :example "(filter (fn (x) (> x 3)) (list 1 5 2 8 3)) ;; → (5 8)") + +(define-special-form "reduce" + :syntax (reduce fn init coll) + :doc "Reduce coll to a single value. fn receives (accumulator element) + and returns the new accumulator. init is the initial value." + :tail-position "none" + :example "(reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4)) ;; → 10") + +(define-special-form "some" + :syntax (some fn coll) + :doc "Return the first truthy result of applying fn to elements of coll, + or nil if none match. Short-circuits on first truthy result." + :tail-position "none" + :example "(some (fn (x) (> x 3)) (list 1 2 5 3)) ;; → true") + +(define-special-form "every?" + :syntax (every? fn coll) + :doc "Return true if fn returns truthy for every element of coll. + Short-circuits on first falsy result." + :tail-position "none" + :example "(every? (fn (x) (> x 0)) (list 1 2 3)) ;; → true") + +(define-special-form "for-each" + :syntax (for-each fn coll) + :doc "Apply fn to each element of coll for side effects. Returns nil." + :tail-position "none" + :example "(for-each (fn (x) (log x)) (list 1 2 3))") + + +;; -------------------------------------------------------------------------- +;; Definition forms (domain-specific) +;; +;; These define named entities in the environment. They are special forms +;; because their arguments have domain-specific structure that the +;; evaluator parses directly. +;; -------------------------------------------------------------------------- + +(define-special-form "defstyle" + :syntax (defstyle name expr) + :doc "Define a named style value. Evaluates expr and binds the result + to name in the environment. The value is typically a class string + or a function that returns class strings." + :tail-position "none" + :example "(defstyle card-style \"rounded-lg shadow-md p-4 bg-white\")") + +(define-special-form "defhandler" + :syntax (defhandler name (&key params ...) body) + :doc "Define an event handler function. Used by the SxEngine for + client-side event handling." + :tail-position "body" + :example "(defhandler toggle-menu (&key target) + (toggle-class target \"hidden\"))") + +(define-special-form "defpage" + :syntax (defpage name &key route method content ...) + :doc "Define a page route. Declares the URL pattern, HTTP method, and + content component for server-side page routing." + :tail-position "none" + :example "(defpage dashboard-page + :route \"/dashboard\" + :content (~dashboard-content))") + +(define-special-form "defquery" + :syntax (defquery name (&key params ...) body) + :doc "Define a named query for data fetching. Used by the resolver + system to declare data dependencies." + :tail-position "body" + :example "(defquery user-profile (&key user-id) + (fetch-user user-id))") + +(define-special-form "defaction" + :syntax (defaction name (&key params ...) body) + :doc "Define a named action for mutations. Like defquery but for + write operations." + :tail-position "body" + :example "(defaction update-profile (&key user-id name email) + (save-user user-id name email))") diff --git a/spec/test-cek.sx b/spec/test-cek.sx new file mode 100644 index 0000000..52ae7b9 --- /dev/null +++ b/spec/test-cek.sx @@ -0,0 +1,241 @@ +;; ========================================================================== +;; test-cek.sx — Tests for the explicit CEK machine evaluator +;; +;; Tests that eval-expr-cek produces identical results to eval-expr. +;; Requires: test-framework.sx, frames.sx, cek.sx loaded. +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. Literals +;; -------------------------------------------------------------------------- + +(defsuite "cek-literals" + (deftest "number" + (assert-equal 42 (eval-expr-cek 42 (test-env)))) + + (deftest "string" + (assert-equal "hello" (eval-expr-cek "hello" (test-env)))) + + (deftest "boolean true" + (assert-equal true (eval-expr-cek true (test-env)))) + + (deftest "boolean false" + (assert-equal false (eval-expr-cek false (test-env)))) + + (deftest "nil" + (assert-nil (eval-expr-cek nil (test-env))))) + + +;; -------------------------------------------------------------------------- +;; 2. Symbol lookup +;; -------------------------------------------------------------------------- + +(defsuite "cek-symbols" + (deftest "env lookup" + (assert-equal 42 + (cek-eval "(do (define x 42) x)"))) + + (deftest "primitive call resolves" + (assert-equal "hello" + (cek-eval "(str \"hello\")")))) + + +;; -------------------------------------------------------------------------- +;; 3. Special forms +;; -------------------------------------------------------------------------- + +(defsuite "cek-if" + (deftest "if true branch" + (assert-equal 1 + (cek-eval "(if true 1 2)"))) + + (deftest "if false branch" + (assert-equal 2 + (cek-eval "(if false 1 2)"))) + + (deftest "if no else" + (assert-nil (cek-eval "(if false 1)")))) + + +(defsuite "cek-when" + (deftest "when true" + (assert-equal 42 + (cek-eval "(when true 42)"))) + + (deftest "when false" + (assert-nil (cek-eval "(when false 42)"))) + + (deftest "when multiple body" + (assert-equal 3 + (cek-eval "(when true 1 2 3)")))) + + +(defsuite "cek-begin" + (deftest "do returns last" + (assert-equal 3 + (cek-eval "(do 1 2 3)"))) + + (deftest "empty do" + (assert-nil (cek-eval "(do)")))) + + +(defsuite "cek-let" + (deftest "basic let" + (assert-equal 3 + (cek-eval "(let ((x 1) (y 2)) (+ x y))"))) + + (deftest "let body sequence" + (assert-equal 10 + (cek-eval "(let ((x 5)) 1 2 (+ x 5))"))) + + (deftest "nested let" + (assert-equal 5 + (cek-eval "(let ((x 1)) (let ((y 2)) (+ x y (* x y))))")))) + + +(defsuite "cek-and-or" + (deftest "and all true" + (assert-equal 3 + (cek-eval "(and 1 2 3)"))) + + (deftest "and short circuit" + (assert-false (cek-eval "(and 1 false 3)"))) + + (deftest "or first true" + (assert-equal 1 + (cek-eval "(or 1 2 3)"))) + + (deftest "or all false" + (assert-false (cek-eval "(or false false false)")))) + + +(defsuite "cek-cond" + (deftest "cond first match" + (assert-equal "a" + (cek-eval "(cond true \"a\" true \"b\")"))) + + (deftest "cond second match" + (assert-equal "b" + (cek-eval "(cond false \"a\" true \"b\")"))) + + (deftest "cond else" + (assert-equal "c" + (cek-eval "(cond false \"a\" :else \"c\")")))) + + +(defsuite "cek-case" + (deftest "case match" + (assert-equal "yes" + (cek-eval "(case 1 1 \"yes\" 2 \"no\")"))) + + (deftest "case no match" + (assert-nil + (cek-eval "(case 3 1 \"yes\" 2 \"no\")"))) + + (deftest "case else" + (assert-equal "default" + (cek-eval "(case 3 1 \"yes\" :else \"default\")")))) + + +;; -------------------------------------------------------------------------- +;; 4. Function calls +;; -------------------------------------------------------------------------- + +(defsuite "cek-calls" + (deftest "primitive call" + (assert-equal 3 + (cek-eval "(+ 1 2)"))) + + (deftest "nested calls" + (assert-equal 6 + (cek-eval "(+ 1 (+ 2 3))"))) + + (deftest "lambda call" + (assert-equal 10 + (cek-eval "((fn (x) (* x 2)) 5)"))) + + (deftest "defined function" + (assert-equal 25 + (cek-eval "(do (define square (fn (x) (* x x))) (square 5))")))) + + +;; -------------------------------------------------------------------------- +;; 5. Define and set! +;; -------------------------------------------------------------------------- + +(defsuite "cek-define" + (deftest "define binds" + (assert-equal 42 + (cek-eval "(do (define x 42) x)"))) + + (deftest "set! mutates" + (assert-equal 10 + (cek-eval "(do (define x 1) (set! x 10) x)")))) + + +;; -------------------------------------------------------------------------- +;; 6. Quote and quasiquote +;; -------------------------------------------------------------------------- + +(defsuite "cek-quote" + (deftest "quote" + (let ((result (cek-eval "(quote (1 2 3))"))) + (assert-equal 3 (len result)))) + + (deftest "quasiquote with unquote" + (assert-equal (list 1 42 3) + (cek-eval "(let ((x 42)) `(1 ,x 3))")))) + + +;; -------------------------------------------------------------------------- +;; 7. Thread-first +;; -------------------------------------------------------------------------- + +(defsuite "cek-thread-first" + (deftest "simple thread" + (assert-equal 3 + (cek-eval "(-> 1 (+ 2))"))) + + (deftest "multi-step thread" + (assert-equal 6 + (cek-eval "(-> 1 (+ 2) (* 2))")))) + + +;; -------------------------------------------------------------------------- +;; 8. CEK-specific: stepping +;; -------------------------------------------------------------------------- + +(defsuite "cek-stepping" + (deftest "single step literal" + (let ((state (make-cek-state 42 (test-env) (list)))) + (let ((stepped (cek-step state))) + (assert-equal "continue" (cek-phase stepped)) + (assert-equal 42 (cek-value stepped)) + (assert-true (cek-terminal? stepped))))) + + (deftest "single step if pushes frame" + (let ((state (make-cek-state (sx-parse-one "(if true 1 2)") (test-env) (list)))) + (let ((stepped (cek-step state))) + (assert-equal "eval" (cek-phase stepped)) + ;; Should have pushed an IfFrame + (assert-true (> (len (cek-kont stepped)) 0)) + (assert-equal "if" (frame-type (first (cek-kont stepped)))))))) + + +;; -------------------------------------------------------------------------- +;; 9. Native continuations (shift/reset in CEK) +;; -------------------------------------------------------------------------- + +(defsuite "cek-continuations" + (deftest "reset passthrough" + (assert-equal 42 + (cek-eval "(reset 42)"))) + + (deftest "shift abort" + (assert-equal 42 + (cek-eval "(reset (+ 1 (shift k 42)))"))) + + (deftest "shift with invoke" + (assert-equal 11 + (cek-eval "(reset (+ 1 (shift k (k 10))))")))) diff --git a/spec/test-continuations.sx b/spec/test-continuations.sx new file mode 100644 index 0000000..0177e70 --- /dev/null +++ b/spec/test-continuations.sx @@ -0,0 +1,140 @@ +;; ========================================================================== +;; test-continuations.sx — Tests for delimited continuations (shift/reset) +;; +;; Requires: test-framework.sx loaded, continuations extension enabled. +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. Basic shift/reset +;; -------------------------------------------------------------------------- + +(defsuite "basic-shift-reset" + (deftest "reset passthrough" + (assert-equal 42 (reset 42))) + + (deftest "reset evaluates expression" + (assert-equal 3 (reset (+ 1 2)))) + + (deftest "shift aborts to reset" + (assert-equal 42 (reset (+ 1 (shift k 42))))) + + (deftest "shift with single invoke" + (assert-equal 11 (reset (+ 1 (shift k (k 10)))))) + + (deftest "shift with multiple invokes" + (assert-equal (list 11 21) + (reset (+ 1 (shift k (list (k 10) (k 20))))))) + + (deftest "shift returns string" + (assert-equal "aborted" + (reset (+ 1 (shift k "aborted"))))) + + (deftest "shift returns nil" + (assert-nil (reset (+ 1 (shift k nil))))) + + (deftest "nested expression with shift" + (assert-equal 16 + (+ 1 (reset (+ 10 (shift k (k 5)))))))) + + +;; -------------------------------------------------------------------------- +;; 2. Continuation predicates +;; -------------------------------------------------------------------------- + +(defsuite "continuation-predicates" + (deftest "k is a continuation inside shift" + (assert-true + (reset (shift k (continuation? k))))) + + (deftest "number is not a continuation" + (assert-false (continuation? 42))) + + (deftest "function is not a continuation" + (assert-false (continuation? (fn (x) x)))) + + (deftest "nil is not a continuation" + (assert-false (continuation? nil))) + + (deftest "string is not a continuation" + (assert-false (continuation? "hello")))) + + +;; -------------------------------------------------------------------------- +;; 3. Continuation as value +;; -------------------------------------------------------------------------- + +(defsuite "continuation-as-value" + (deftest "k returned from reset" + ;; shift body returns k itself — reset returns the continuation + (let ((k (reset (+ 1 (shift k k))))) + (assert-true (continuation? k)) + (assert-equal 11 (k 10)))) + + (deftest "invoke returned k multiple times" + (let ((k (reset (+ 1 (shift k k))))) + (assert-equal 11 (k 10)) + (assert-equal 21 (k 20)) + (assert-equal 2 (k 1)))) + + (deftest "pass k to another function" + (let ((apply-k (fn (k v) (k v)))) + (assert-equal 15 + (reset (+ 5 (shift k (apply-k k 10))))))) + + (deftest "k in data structure" + (let ((result (reset (+ 1 (shift k (list k 42)))))) + (assert-equal 42 (nth result 1)) + (assert-equal 100 ((first result) 99))))) + + +;; -------------------------------------------------------------------------- +;; 4. Nested reset +;; -------------------------------------------------------------------------- + +(defsuite "nested-reset" + (deftest "inner reset captures independently" + (assert-equal 12 + (reset (+ 1 (reset (+ 10 (shift k (k 1)))))))) + + (deftest "inner abort outer continues" + (assert-equal 43 + (reset (+ 1 (reset (+ 10 (shift k 42))))))) + + (deftest "outer shift captures outer reset" + (assert-equal 100 + (reset (+ 1 (shift k (k 99))))))) + + +;; -------------------------------------------------------------------------- +;; 5. Interaction with scoped effects +;; -------------------------------------------------------------------------- + +(defsuite "continuations-with-scopes" + (deftest "provide survives resume" + (assert-equal "dark" + (reset (provide "theme" "dark" + (+ 0 (shift k (k 0))) + (context "theme"))))) + + (deftest "scope and emit across shift" + (assert-equal (list "a") + (reset (scope "acc" + (emit! "acc" "a") + (+ 0 (shift k (k 0))) + (emitted "acc")))))) + + +;; -------------------------------------------------------------------------- +;; 6. TCO interaction +;; -------------------------------------------------------------------------- + +(defsuite "tco-interaction" + (deftest "shift in tail position" + (assert-equal 42 + (reset (if true (shift k (k 42)) 0)))) + + (deftest "shift in let body" + (assert-equal 10 + (reset (let ((x 5)) + (+ x (shift k (k 5)))))))) diff --git a/spec/test-eval.sx b/spec/test-eval.sx new file mode 100644 index 0000000..33885f7 --- /dev/null +++ b/spec/test-eval.sx @@ -0,0 +1,746 @@ +;; ========================================================================== +;; test-eval.sx — Tests for the core evaluator and primitives +;; +;; Requires: test-framework.sx loaded first. +;; Modules tested: eval.sx, primitives.sx +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; Literals and types +;; -------------------------------------------------------------------------- + +(defsuite "literals" + (deftest "numbers are numbers" + (assert-type "number" 42) + (assert-type "number" 3.14) + (assert-type "number" -1)) + + (deftest "strings are strings" + (assert-type "string" "hello") + (assert-type "string" "")) + + (deftest "booleans are booleans" + (assert-type "boolean" true) + (assert-type "boolean" false)) + + (deftest "nil is nil" + (assert-type "nil" nil) + (assert-nil nil)) + + (deftest "lists are lists" + (assert-type "list" (list 1 2 3)) + (assert-type "list" (list))) + + (deftest "dicts are dicts" + (assert-type "dict" {:a 1 :b 2}))) + + +;; -------------------------------------------------------------------------- +;; Arithmetic +;; -------------------------------------------------------------------------- + +(defsuite "arithmetic" + (deftest "addition" + (assert-equal 3 (+ 1 2)) + (assert-equal 0 (+ 0 0)) + (assert-equal -1 (+ 1 -2)) + (assert-equal 10 (+ 1 2 3 4))) + + (deftest "subtraction" + (assert-equal 1 (- 3 2)) + (assert-equal -1 (- 2 3))) + + (deftest "multiplication" + (assert-equal 6 (* 2 3)) + (assert-equal 0 (* 0 100)) + (assert-equal 24 (* 1 2 3 4))) + + (deftest "division" + (assert-equal 2 (/ 6 3)) + (assert-equal 2.5 (/ 5 2))) + + (deftest "modulo" + (assert-equal 1 (mod 7 3)) + (assert-equal 0 (mod 6 3)))) + + +;; -------------------------------------------------------------------------- +;; Comparison +;; -------------------------------------------------------------------------- + +(defsuite "comparison" + (deftest "equality" + (assert-true (= 1 1)) + (assert-false (= 1 2)) + (assert-true (= "a" "a")) + (assert-false (= "a" "b"))) + + (deftest "deep equality" + (assert-true (equal? (list 1 2 3) (list 1 2 3))) + (assert-false (equal? (list 1 2) (list 1 3))) + (assert-true (equal? {:a 1} {:a 1})) + (assert-false (equal? {:a 1} {:a 2}))) + + (deftest "ordering" + (assert-true (< 1 2)) + (assert-false (< 2 1)) + (assert-true (> 2 1)) + (assert-true (<= 1 1)) + (assert-true (<= 1 2)) + (assert-true (>= 2 2)) + (assert-true (>= 3 2)))) + + +;; -------------------------------------------------------------------------- +;; String operations +;; -------------------------------------------------------------------------- + +(defsuite "strings" + (deftest "str concatenation" + (assert-equal "abc" (str "a" "b" "c")) + (assert-equal "hello world" (str "hello" " " "world")) + (assert-equal "42" (str 42)) + (assert-equal "" (str))) + + (deftest "string-length" + (assert-equal 5 (string-length "hello")) + (assert-equal 0 (string-length ""))) + + (deftest "substring" + (assert-equal "ell" (substring "hello" 1 4)) + (assert-equal "hello" (substring "hello" 0 5))) + + (deftest "string-contains?" + (assert-true (string-contains? "hello world" "world")) + (assert-false (string-contains? "hello" "xyz"))) + + (deftest "upcase and downcase" + (assert-equal "HELLO" (upcase "hello")) + (assert-equal "hello" (downcase "HELLO"))) + + (deftest "trim" + (assert-equal "hello" (trim " hello ")) + (assert-equal "hello" (trim "hello"))) + + (deftest "split and join" + (assert-equal (list "a" "b" "c") (split "a,b,c" ",")) + (assert-equal "a-b-c" (join "-" (list "a" "b" "c"))))) + + +;; -------------------------------------------------------------------------- +;; List operations +;; -------------------------------------------------------------------------- + +(defsuite "lists" + (deftest "constructors" + (assert-equal (list 1 2 3) (list 1 2 3)) + (assert-equal (list) (list)) + (assert-length 3 (list 1 2 3))) + + (deftest "first and rest" + (assert-equal 1 (first (list 1 2 3))) + (assert-equal (list 2 3) (rest (list 1 2 3))) + (assert-nil (first (list))) + (assert-equal (list) (rest (list)))) + + (deftest "nth" + (assert-equal 1 (nth (list 1 2 3) 0)) + (assert-equal 2 (nth (list 1 2 3) 1)) + (assert-equal 3 (nth (list 1 2 3) 2))) + + (deftest "last" + (assert-equal 3 (last (list 1 2 3))) + (assert-nil (last (list)))) + + (deftest "cons and append" + (assert-equal (list 0 1 2) (cons 0 (list 1 2))) + (assert-equal (list 1 2 3 4) (append (list 1 2) (list 3 4)))) + + (deftest "reverse" + (assert-equal (list 3 2 1) (reverse (list 1 2 3))) + (assert-equal (list) (reverse (list)))) + + (deftest "empty?" + (assert-true (empty? (list))) + (assert-false (empty? (list 1)))) + + (deftest "len" + (assert-equal 0 (len (list))) + (assert-equal 3 (len (list 1 2 3)))) + + (deftest "contains?" + (assert-true (contains? (list 1 2 3) 2)) + (assert-false (contains? (list 1 2 3) 4))) + + (deftest "flatten" + (assert-equal (list 1 2 3 4) (flatten (list (list 1 2) (list 3 4)))))) + + +;; -------------------------------------------------------------------------- +;; Dict operations +;; -------------------------------------------------------------------------- + +(defsuite "dicts" + (deftest "dict literal" + (assert-type "dict" {:a 1 :b 2}) + (assert-equal 1 (get {:a 1} "a")) + (assert-equal 2 (get {:a 1 :b 2} "b"))) + + (deftest "assoc" + (assert-equal {:a 1 :b 2} (assoc {:a 1} "b" 2)) + (assert-equal {:a 99} (assoc {:a 1} "a" 99))) + + (deftest "dissoc" + (assert-equal {:b 2} (dissoc {:a 1 :b 2} "a"))) + + (deftest "keys and vals" + (let ((d {:a 1 :b 2})) + (assert-length 2 (keys d)) + (assert-length 2 (vals d)) + (assert-contains "a" (keys d)) + (assert-contains "b" (keys d)))) + + (deftest "has-key?" + (assert-true (has-key? {:a 1} "a")) + (assert-false (has-key? {:a 1} "b"))) + + (deftest "merge" + (assert-equal {:a 1 :b 2 :c 3} + (merge {:a 1 :b 2} {:c 3})) + (assert-equal {:a 99 :b 2} + (merge {:a 1 :b 2} {:a 99})))) + + +;; -------------------------------------------------------------------------- +;; Predicates +;; -------------------------------------------------------------------------- + +(defsuite "predicates" + (deftest "nil?" + (assert-true (nil? nil)) + (assert-false (nil? 0)) + (assert-false (nil? false)) + (assert-false (nil? ""))) + + (deftest "number?" + (assert-true (number? 42)) + (assert-true (number? 3.14)) + (assert-false (number? "42"))) + + (deftest "string?" + (assert-true (string? "hello")) + (assert-false (string? 42))) + + (deftest "list?" + (assert-true (list? (list 1 2))) + (assert-false (list? "not a list"))) + + (deftest "dict?" + (assert-true (dict? {:a 1})) + (assert-false (dict? (list 1)))) + + (deftest "boolean?" + (assert-true (boolean? true)) + (assert-true (boolean? false)) + (assert-false (boolean? nil)) + (assert-false (boolean? 0))) + + (deftest "not" + (assert-true (not false)) + (assert-true (not nil)) + (assert-false (not true)) + (assert-false (not 1)) + (assert-false (not "x")))) + + +;; -------------------------------------------------------------------------- +;; Special forms +;; -------------------------------------------------------------------------- + +(defsuite "special-forms" + (deftest "if" + (assert-equal "yes" (if true "yes" "no")) + (assert-equal "no" (if false "yes" "no")) + (assert-equal "no" (if nil "yes" "no")) + (assert-nil (if false "yes"))) + + (deftest "when" + (assert-equal "yes" (when true "yes")) + (assert-nil (when false "yes"))) + + (deftest "cond" + (assert-equal "a" (cond true "a" :else "b")) + (assert-equal "b" (cond false "a" :else "b")) + (assert-equal "c" (cond + false "a" + false "b" + :else "c"))) + + (deftest "cond with 2-element predicate as first test" + ;; Regression: cond misclassifies Clojure-style as scheme-style when + ;; the first test is a 2-element list like (nil? x) or (empty? x). + ;; The evaluator checks: is first arg a 2-element list? If yes, treats + ;; as scheme-style ((test body) ...) — returning the arg instead of + ;; evaluating the predicate call. + (assert-equal 0 (cond (nil? nil) 0 :else 1)) + (assert-equal 1 (cond (nil? "x") 0 :else 1)) + (assert-equal "empty" (cond (empty? (list)) "empty" :else "not-empty")) + (assert-equal "not-empty" (cond (empty? (list 1)) "empty" :else "not-empty")) + (assert-equal "yes" (cond (not false) "yes" :else "no")) + (assert-equal "no" (cond (not true) "yes" :else "no"))) + + (deftest "cond with 2-element predicate and no :else" + ;; Same bug, but without :else — this is the worst case because the + ;; bootstrapper heuristic also breaks (all clauses are 2-element lists). + (assert-equal "found" + (cond (nil? nil) "found" + (nil? "x") "other")) + (assert-equal "b" + (cond (nil? "x") "a" + (not false) "b"))) + + (deftest "and" + (assert-true (and true true)) + (assert-false (and true false)) + (assert-false (and false true)) + (assert-equal 3 (and 1 2 3))) + + (deftest "or" + (assert-equal 1 (or 1 2)) + (assert-equal 2 (or false 2)) + (assert-equal "fallback" (or nil false "fallback")) + (assert-false (or false false))) + + (deftest "let" + (assert-equal 3 (let ((x 1) (y 2)) (+ x y))) + (assert-equal "hello world" + (let ((a "hello") (b " world")) (str a b)))) + + (deftest "let clojure-style" + (assert-equal 3 (let (x 1 y 2) (+ x y)))) + + (deftest "do / begin" + (assert-equal 3 (do 1 2 3)) + (assert-equal "last" (begin "first" "middle" "last"))) + + (deftest "define" + (define x 42) + (assert-equal 42 x)) + + (deftest "set!" + (define x 1) + (set! x 2) + (assert-equal 2 x))) + + +;; -------------------------------------------------------------------------- +;; Lambda and closures +;; -------------------------------------------------------------------------- + +(defsuite "lambdas" + (deftest "basic lambda" + (let ((add (fn (a b) (+ a b)))) + (assert-equal 3 (add 1 2)))) + + (deftest "closure captures env" + (let ((x 10)) + (let ((add-x (fn (y) (+ x y)))) + (assert-equal 15 (add-x 5))))) + + (deftest "lambda as argument" + (assert-equal (list 2 4 6) + (map (fn (x) (* x 2)) (list 1 2 3)))) + + (deftest "recursive lambda via define" + (define factorial + (fn (n) (if (<= n 1) 1 (* n (factorial (- n 1)))))) + (assert-equal 120 (factorial 5))) + + (deftest "higher-order returns lambda" + (let ((make-adder (fn (n) (fn (x) (+ n x))))) + (let ((add5 (make-adder 5))) + (assert-equal 8 (add5 3))))) + + (deftest "multi-body lambda returns last value" + ;; All body expressions must execute. Return value is the last. + ;; Catches: sf-lambda using nth(args,1) instead of rest(args). + (let ((f (fn (x) (+ x 1) (+ x 2) (+ x 3)))) + (assert-equal 13 (f 10)))) + + (deftest "multi-body lambda side effects via dict mutation" + ;; Verify all body expressions run by mutating a shared dict. + (let ((state (dict "a" 0 "b" 0))) + (let ((f (fn () + (dict-set! state "a" 1) + (dict-set! state "b" 2) + "done"))) + (assert-equal "done" (f)) + (assert-equal 1 (get state "a")) + (assert-equal 2 (get state "b"))))) + + (deftest "multi-body lambda two expressions" + ;; Simplest case: two body expressions, return value is second. + (assert-equal 20 + ((fn (x) (+ x 1) (* x 2)) 10)) + ;; And with zero-arg lambda + (assert-equal 42 + ((fn () (+ 1 2) 42))))) + + +;; -------------------------------------------------------------------------- +;; Higher-order forms +;; -------------------------------------------------------------------------- + +(defsuite "higher-order" + (deftest "map" + (assert-equal (list 2 4 6) + (map (fn (x) (* x 2)) (list 1 2 3))) + (assert-equal (list) (map (fn (x) x) (list)))) + + (deftest "filter" + (assert-equal (list 2 4) + (filter (fn (x) (= (mod x 2) 0)) (list 1 2 3 4))) + (assert-equal (list) + (filter (fn (x) false) (list 1 2 3)))) + + (deftest "reduce" + (assert-equal 10 (reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4))) + (assert-equal 0 (reduce (fn (acc x) (+ acc x)) 0 (list)))) + + (deftest "some" + (assert-true (some (fn (x) (> x 3)) (list 1 2 3 4 5))) + (assert-false (some (fn (x) (> x 10)) (list 1 2 3)))) + + (deftest "every?" + (assert-true (every? (fn (x) (> x 0)) (list 1 2 3))) + (assert-false (every? (fn (x) (> x 2)) (list 1 2 3)))) + + (deftest "map-indexed" + (assert-equal (list "0:a" "1:b" "2:c") + (map-indexed (fn (i x) (str i ":" x)) (list "a" "b" "c"))))) + + +;; -------------------------------------------------------------------------- +;; Components +;; -------------------------------------------------------------------------- + +(defsuite "components" + (deftest "defcomp creates component" + (defcomp ~test-comp (&key title) + (div title)) + (assert-true (not (nil? ~test-comp)))) + + (deftest "component renders with keyword args" + (defcomp ~greeting (&key name) + (span (str "Hello, " name "!"))) + (assert-true (not (nil? ~greeting)))) + + (deftest "component with children" + (defcomp ~box (&key &rest children) + (div :class "box" children)) + (assert-true (not (nil? ~box)))) + + (deftest "component with default via or" + (defcomp ~label (&key text) + (span (or text "default"))) + (assert-true (not (nil? ~label)))) + + (deftest "defcomp default affinity is auto" + (defcomp ~aff-default (&key x) + (div x)) + (assert-equal "auto" (component-affinity ~aff-default))) + + (deftest "defcomp affinity client" + (defcomp ~aff-client (&key x) + :affinity :client + (div x)) + (assert-equal "client" (component-affinity ~aff-client))) + + (deftest "defcomp affinity server" + (defcomp ~aff-server (&key x) + :affinity :server + (div x)) + (assert-equal "server" (component-affinity ~aff-server))) + + (deftest "defcomp affinity preserves body" + (defcomp ~aff-body (&key val) + :affinity :client + (span val)) + ;; Component should still render correctly + (assert-equal "client" (component-affinity ~aff-body)) + (assert-true (not (nil? ~aff-body))))) + + +;; -------------------------------------------------------------------------- +;; Macros +;; -------------------------------------------------------------------------- + +(defsuite "macros" + (deftest "defmacro creates macro" + (defmacro unless (cond &rest body) + `(if (not ,cond) (do ,@body))) + (assert-equal "yes" (unless false "yes")) + (assert-nil (unless true "no"))) + + (deftest "quasiquote and unquote" + (let ((x 42)) + (assert-equal (list 1 42 3) `(1 ,x 3)))) + + (deftest "splice-unquote" + (let ((xs (list 2 3 4))) + (assert-equal (list 1 2 3 4 5) `(1 ,@xs 5))))) + + +;; -------------------------------------------------------------------------- +;; Threading macro +;; -------------------------------------------------------------------------- + +(defsuite "threading" + (deftest "thread-first" + (assert-equal 8 (-> 5 (+ 1) (+ 2))) + (assert-equal "HELLO" (-> "hello" upcase)) + (assert-equal "HELLO WORLD" + (-> "hello" + (str " world") + upcase)))) + + +;; -------------------------------------------------------------------------- +;; Truthiness +;; -------------------------------------------------------------------------- + +(defsuite "truthiness" + (deftest "truthy values" + (assert-true (if 1 true false)) + (assert-true (if "x" true false)) + (assert-true (if (list 1) true false)) + (assert-true (if true true false))) + + (deftest "falsy values" + (assert-false (if false true false)) + (assert-false (if nil true false))) + + ;; NOTE: empty list, zero, and empty string truthiness is + ;; platform-dependent. Python treats all three as falsy. + ;; JavaScript treats [] as truthy but 0 and "" as falsy. + ;; These tests are omitted — each bootstrapper should emit + ;; platform-specific truthiness tests instead. + ) + + +;; -------------------------------------------------------------------------- +;; Edge cases and regression tests +;; -------------------------------------------------------------------------- + +(defsuite "edge-cases" + (deftest "nested let scoping" + (let ((x 1)) + (let ((x 2)) + (assert-equal 2 x)) + ;; outer x should be unchanged by inner let + ;; (this tests that let creates a new scope) + )) + + (deftest "recursive map" + (assert-equal (list (list 2 4) (list 6 8)) + (map (fn (sub) (map (fn (x) (* x 2)) sub)) + (list (list 1 2) (list 3 4))))) + + (deftest "keyword as value" + (assert-equal "class" :class) + (assert-equal "id" :id)) + + (deftest "dict with evaluated values" + (let ((x 42)) + (assert-equal 42 (get {:val x} "val")))) + + (deftest "nil propagation" + (assert-nil (get {:a 1} "missing")) + (assert-equal "default" (or (get {:a 1} "missing") "default"))) + + (deftest "empty operations" + (assert-equal (list) (map (fn (x) x) (list))) + (assert-equal (list) (filter (fn (x) true) (list))) + (assert-equal 0 (reduce (fn (acc x) (+ acc x)) 0 (list))) + (assert-equal 0 (len (list))) + (assert-equal "" (str)))) + + +;; -------------------------------------------------------------------------- +;; Server-only tests — skip in browser (defpage, streaming functions) +;; These require forms.sx which is only loaded server-side. +;; -------------------------------------------------------------------------- + +(when (get (try-call (fn () stream-chunk-id)) "ok") + +(defsuite "defpage" + (deftest "basic defpage returns page-def" + (let ((p (defpage test-basic :path "/test" :auth :public :content (div "hello")))) + (assert-true (not (nil? p))) + (assert-equal "test-basic" (get p "name")) + (assert-equal "/test" (get p "path")) + (assert-equal "public" (get p "auth")))) + + (deftest "defpage content expr is unevaluated AST" + (let ((p (defpage test-content :path "/c" :auth :public :content (~my-comp :title "hi")))) + (assert-true (not (nil? (get p "content")))))) + + (deftest "defpage with :stream" + (let ((p (defpage test-stream :path "/s" :auth :public :stream true :content (div "x")))) + (assert-equal true (get p "stream")))) + + (deftest "defpage with :shell" + (let ((p (defpage test-shell :path "/sh" :auth :public :stream true + :shell (~my-layout (~suspense :id "data" :fallback (div "loading..."))) + :content (~my-streamed :data data-val)))) + (assert-true (not (nil? (get p "shell")))) + (assert-true (not (nil? (get p "content")))))) + + (deftest "defpage with :fallback" + (let ((p (defpage test-fallback :path "/f" :auth :public :stream true + :fallback (div :class "skeleton" "loading") + :content (div "done")))) + (assert-true (not (nil? (get p "fallback")))))) + + (deftest "defpage with :data" + (let ((p (defpage test-data :path "/d" :auth :public + :data (fetch-items) + :content (~items-list :items items)))) + (assert-true (not (nil? (get p "data")))))) + + (deftest "defpage missing fields are nil" + (let ((p (defpage test-minimal :path "/m" :auth :public :content (div "x")))) + (assert-nil (get p "data")) + (assert-nil (get p "filter")) + (assert-nil (get p "aside")) + (assert-nil (get p "menu")) + (assert-nil (get p "shell")) + (assert-nil (get p "fallback")) + (assert-equal false (get p "stream"))))) + +;; -------------------------------------------------------------------------- +;; Multi-stream data protocol (from forms.sx) +;; -------------------------------------------------------------------------- + +(defsuite "stream-chunk-id" + (deftest "extracts stream-id from chunk" + (assert-equal "my-slot" (stream-chunk-id {"stream-id" "my-slot" "x" 1}))) + + (deftest "defaults to stream-content when missing" + (assert-equal "stream-content" (stream-chunk-id {"x" 1 "y" 2})))) + +(defsuite "stream-chunk-bindings" + (deftest "removes stream-id from chunk" + (let ((bindings (stream-chunk-bindings {"stream-id" "slot" "name" "alice" "age" 30}))) + (assert-equal "alice" (get bindings "name")) + (assert-equal 30 (get bindings "age")) + (assert-nil (get bindings "stream-id")))) + + (deftest "returns all keys when no stream-id" + (let ((bindings (stream-chunk-bindings {"a" 1 "b" 2}))) + (assert-equal 1 (get bindings "a")) + (assert-equal 2 (get bindings "b"))))) + +(defsuite "normalize-binding-key" + (deftest "converts underscores to hyphens" + (assert-equal "my-key" (normalize-binding-key "my_key"))) + + (deftest "leaves hyphens unchanged" + (assert-equal "my-key" (normalize-binding-key "my-key"))) + + (deftest "handles multiple underscores" + (assert-equal "a-b-c" (normalize-binding-key "a_b_c")))) + +(defsuite "bind-stream-chunk" + (deftest "creates fresh env with bindings" + (let ((base {"existing" 42}) + (chunk {"stream-id" "slot" "user-name" "bob" "count" 5}) + (env (bind-stream-chunk chunk base))) + ;; Base env bindings are preserved + (assert-equal 42 (get env "existing")) + ;; Chunk bindings are added (stream-id removed) + (assert-equal "bob" (get env "user-name")) + (assert-equal 5 (get env "count")) + ;; stream-id is not in env + (assert-nil (get env "stream-id")))) + + (deftest "isolates env from base — bindings don't leak to base" + (let ((base {"x" 1}) + (chunk {"stream-id" "s" "y" 2}) + (env (bind-stream-chunk chunk base))) + ;; Chunk bindings should not appear in base + (assert-nil (get base "y")) + ;; Base bindings should be in derived env + (assert-equal 1 (get env "x"))))) + +(defsuite "validate-stream-data" + (deftest "valid: list of dicts" + (assert-true (validate-stream-data + (list {"stream-id" "a" "x" 1} + {"stream-id" "b" "y" 2})))) + + (deftest "valid: empty list" + (assert-true (validate-stream-data (list)))) + + (deftest "invalid: single dict (not a list)" + (assert-equal false (validate-stream-data {"x" 1}))) + + (deftest "invalid: list containing non-dict" + (assert-equal false (validate-stream-data (list {"x" 1} "oops" {"y" 2}))))) + + +;; -------------------------------------------------------------------------- +;; Multi-stream end-to-end scenarios +;; -------------------------------------------------------------------------- + +(defsuite "multi-stream routing" + (deftest "stream-chunk-id routes different chunks to different slots" + (let ((chunks (list + {"stream-id" "stream-fast" "msg" "quick"} + {"stream-id" "stream-medium" "msg" "steady"} + {"stream-id" "stream-slow" "msg" "slow"})) + (ids (map stream-chunk-id chunks))) + (assert-equal "stream-fast" (nth ids 0)) + (assert-equal "stream-medium" (nth ids 1)) + (assert-equal "stream-slow" (nth ids 2)))) + + (deftest "bind-stream-chunk creates isolated envs per chunk" + (let ((base {"layout" "main"}) + (chunk-a {"stream-id" "a" "title" "First" "count" 1}) + (chunk-b {"stream-id" "b" "title" "Second" "count" 2}) + (env-a (bind-stream-chunk chunk-a base)) + (env-b (bind-stream-chunk chunk-b base))) + ;; Each env has its own bindings + (assert-equal "First" (get env-a "title")) + (assert-equal "Second" (get env-b "title")) + (assert-equal 1 (get env-a "count")) + (assert-equal 2 (get env-b "count")) + ;; Both share base + (assert-equal "main" (get env-a "layout")) + (assert-equal "main" (get env-b "layout")) + ;; Neither leaks into base + (assert-nil (get base "title")))) + + (deftest "normalize-binding-key applied to chunk keys" + (let ((chunk {"stream-id" "s" "user_name" "alice" "item_count" 3}) + (bindings (stream-chunk-bindings chunk))) + ;; Keys with underscores need normalizing for SX env + (assert-equal "alice" (get bindings "user_name")) + ;; normalize-binding-key converts them + (assert-equal "user-name" (normalize-binding-key "user_name")) + (assert-equal "item-count" (normalize-binding-key "item_count")))) + + (deftest "defpage stream flag defaults to false" + (let ((p (defpage test-no-stream :path "/ns" :auth :public :content (div "x")))) + (assert-equal false (get p "stream")))) + + (deftest "defpage stream true recorded in page-def" + (let ((p (defpage test-with-stream :path "/ws" :auth :public + :stream true + :shell (~layout (~suspense :id "data")) + :content (~chunk :val val)))) + (assert-equal true (get p "stream")) + (assert-true (not (nil? (get p "shell"))))))) + +) ;; end (when has-server-forms?) diff --git a/spec/test-framework.sx b/spec/test-framework.sx new file mode 100644 index 0000000..3a80ca0 --- /dev/null +++ b/spec/test-framework.sx @@ -0,0 +1,86 @@ +;; ========================================================================== +;; test-framework.sx — Reusable test macros and assertion helpers +;; +;; Loaded first by all test runners. Provides deftest, defsuite, and +;; assertion helpers. Requires 5 platform functions from the host: +;; +;; try-call (thunk) -> {:ok true} | {:ok false :error "msg"} +;; report-pass (name) -> platform-specific pass output +;; report-fail (name error) -> platform-specific fail output +;; push-suite (name) -> push suite name onto context stack +;; pop-suite () -> pop suite name from context stack +;; +;; Any host that provides these 5 functions can run any test spec. +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. Test framework macros +;; -------------------------------------------------------------------------- + +(defmacro deftest (name &rest body) + `(let ((result (try-call (fn () ,@body)))) + (if (get result "ok") + (report-pass ,name) + (report-fail ,name (get result "error"))))) + +(defmacro defsuite (name &rest items) + `(do (push-suite ,name) + ,@items + (pop-suite))) + + +;; -------------------------------------------------------------------------- +;; 2. Assertion helpers — defined in SX, available in test bodies +;; -------------------------------------------------------------------------- + +(define assert-equal + (fn (expected actual) + (assert (equal? expected actual) + (str "Expected " (str expected) " but got " (str actual))))) + +(define assert-not-equal + (fn (a b) + (assert (not (equal? a b)) + (str "Expected values to differ but both are " (str a))))) + +(define assert-true + (fn (val) + (assert val (str "Expected truthy but got " (str val))))) + +(define assert-false + (fn (val) + (assert (not val) (str "Expected falsy but got " (str val))))) + +(define assert-nil + (fn (val) + (assert (nil? val) (str "Expected nil but got " (str val))))) + +(define assert-type + (fn ((expected-type :as string) val) + (let ((actual-type + (if (nil? val) "nil" + (if (boolean? val) "boolean" + (if (number? val) "number" + (if (string? val) "string" + (if (list? val) "list" + (if (dict? val) "dict" + "unknown")))))))) + (assert (= expected-type actual-type) + (str "Expected type " expected-type " but got " actual-type))))) + +(define assert-length + (fn ((expected-len :as number) (col :as list)) + (assert (= (len col) expected-len) + (str "Expected length " expected-len " but got " (len col))))) + +(define assert-contains + (fn (item (col :as list)) + (assert (some (fn (x) (equal? x item)) col) + (str "Expected collection to contain " (str item))))) + +(define assert-throws + (fn ((thunk :as lambda)) + (let ((result (try-call thunk))) + (assert (not (get result "ok")) + "Expected an error to be thrown but none was")))) diff --git a/spec/test-parser.sx b/spec/test-parser.sx new file mode 100644 index 0000000..640f0ce --- /dev/null +++ b/spec/test-parser.sx @@ -0,0 +1,259 @@ +;; ========================================================================== +;; test-parser.sx — Tests for the SX parser and serializer +;; +;; Requires: test-framework.sx loaded first. +;; Modules tested: parser.sx +;; +;; Platform functions required (beyond test framework): +;; sx-parse (source) -> list of AST expressions +;; sx-serialize (expr) -> SX source string +;; make-symbol (name) -> Symbol value +;; make-keyword (name) -> Keyword value +;; symbol-name (sym) -> string +;; keyword-name (kw) -> string +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; Literal parsing +;; -------------------------------------------------------------------------- + +(defsuite "parser-literals" + (deftest "parse integers" + (assert-equal (list 42) (sx-parse "42")) + (assert-equal (list 0) (sx-parse "0")) + (assert-equal (list -7) (sx-parse "-7"))) + + (deftest "parse floats" + (assert-equal (list 3.14) (sx-parse "3.14")) + (assert-equal (list -0.5) (sx-parse "-0.5"))) + + (deftest "parse strings" + (assert-equal (list "hello") (sx-parse "\"hello\"")) + (assert-equal (list "") (sx-parse "\"\""))) + + (deftest "parse escape: newline" + (assert-equal (list "a\nb") (sx-parse "\"a\\nb\""))) + + (deftest "parse escape: tab" + (assert-equal (list "a\tb") (sx-parse "\"a\\tb\""))) + + (deftest "parse escape: quote" + (assert-equal (list "a\"b") (sx-parse "\"a\\\"b\""))) + + (deftest "parse booleans" + (assert-equal (list true) (sx-parse "true")) + (assert-equal (list false) (sx-parse "false"))) + + (deftest "parse nil" + (assert-equal (list nil) (sx-parse "nil"))) + + (deftest "parse keywords" + (let ((result (sx-parse ":hello"))) + (assert-length 1 result) + (assert-equal "hello" (keyword-name (first result))))) + + (deftest "parse symbols" + (let ((result (sx-parse "foo"))) + (assert-length 1 result) + (assert-equal "foo" (symbol-name (first result)))))) + + +;; -------------------------------------------------------------------------- +;; Composite parsing +;; -------------------------------------------------------------------------- + +(defsuite "parser-lists" + (deftest "parse empty list" + (let ((result (sx-parse "()"))) + (assert-length 1 result) + (assert-equal (list) (first result)))) + + (deftest "parse list of numbers" + (let ((result (sx-parse "(1 2 3)"))) + (assert-length 1 result) + (assert-equal (list 1 2 3) (first result)))) + + (deftest "parse nested lists" + (let ((result (sx-parse "(1 (2 3) 4)"))) + (assert-length 1 result) + (assert-equal (list 1 (list 2 3) 4) (first result)))) + + (deftest "parse square brackets as list" + (let ((result (sx-parse "[1 2 3]"))) + (assert-length 1 result) + (assert-equal (list 1 2 3) (first result)))) + + (deftest "parse mixed types" + (let ((result (sx-parse "(42 \"hello\" true nil)"))) + (assert-length 1 result) + (let ((lst (first result))) + (assert-equal 42 (nth lst 0)) + (assert-equal "hello" (nth lst 1)) + (assert-equal true (nth lst 2)) + (assert-nil (nth lst 3)))))) + + +;; -------------------------------------------------------------------------- +;; Dict parsing +;; -------------------------------------------------------------------------- + +(defsuite "parser-dicts" + (deftest "parse empty dict" + (let ((result (sx-parse "{}"))) + (assert-length 1 result) + (assert-type "dict" (first result)))) + + (deftest "parse dict with keyword keys" + (let ((result (sx-parse "{:a 1 :b 2}"))) + (assert-length 1 result) + (let ((d (first result))) + (assert-type "dict" d) + (assert-equal 1 (get d "a")) + (assert-equal 2 (get d "b"))))) + + (deftest "parse dict with string values" + (let ((result (sx-parse "{:name \"alice\"}"))) + (assert-length 1 result) + (assert-equal "alice" (get (first result) "name"))))) + + +;; -------------------------------------------------------------------------- +;; Comments and whitespace +;; -------------------------------------------------------------------------- + +(defsuite "parser-whitespace" + (deftest "skip line comments" + (assert-equal (list 42) (sx-parse ";; comment\n42")) + (assert-equal (list 1 2) (sx-parse "1 ;; middle\n2"))) + + (deftest "skip whitespace" + (assert-equal (list 42) (sx-parse " 42 ")) + (assert-equal (list 1 2) (sx-parse " 1 \n\t 2 "))) + + (deftest "parse multiple top-level expressions" + (assert-length 3 (sx-parse "1 2 3")) + (assert-equal (list 1 2 3) (sx-parse "1 2 3"))) + + (deftest "empty input" + (assert-equal (list) (sx-parse ""))) + + (deftest "only comments" + (assert-equal (list) (sx-parse ";; just a comment\n;; another")))) + + +;; -------------------------------------------------------------------------- +;; Quote sugar +;; -------------------------------------------------------------------------- + +(defsuite "parser-quote-sugar" + (deftest "quasiquote" + (let ((result (sx-parse "`foo"))) + (assert-length 1 result) + (let ((expr (first result))) + (assert-type "list" expr) + (assert-equal "quasiquote" (symbol-name (first expr)))))) + + (deftest "unquote" + (let ((result (sx-parse ",foo"))) + (assert-length 1 result) + (let ((expr (first result))) + (assert-type "list" expr) + (assert-equal "unquote" (symbol-name (first expr)))))) + + (deftest "splice-unquote" + (let ((result (sx-parse ",@foo"))) + (assert-length 1 result) + (let ((expr (first result))) + (assert-type "list" expr) + (assert-equal "splice-unquote" (symbol-name (first expr))))))) + + +;; -------------------------------------------------------------------------- +;; Serializer +;; -------------------------------------------------------------------------- + +(defsuite "serializer" + (deftest "serialize number" + (assert-equal "42" (sx-serialize 42))) + + (deftest "serialize string" + (assert-equal "\"hello\"" (sx-serialize "hello"))) + + (deftest "serialize boolean" + (assert-equal "true" (sx-serialize true)) + (assert-equal "false" (sx-serialize false))) + + (deftest "serialize nil" + (assert-equal "nil" (sx-serialize nil))) + + (deftest "serialize keyword" + (assert-equal ":foo" (sx-serialize (make-keyword "foo")))) + + (deftest "serialize symbol" + (assert-equal "bar" (sx-serialize (make-symbol "bar")))) + + (deftest "serialize list" + (assert-equal "(1 2 3)" (sx-serialize (list 1 2 3)))) + + (deftest "serialize empty list" + (assert-equal "()" (sx-serialize (list)))) + + (deftest "serialize nested" + (assert-equal "(1 (2 3) 4)" (sx-serialize (list 1 (list 2 3) 4))))) + + +;; -------------------------------------------------------------------------- +;; Round-trip: parse then serialize +;; -------------------------------------------------------------------------- + +(defsuite "parser-roundtrip" + (deftest "roundtrip number" + (assert-equal "42" (sx-serialize (first (sx-parse "42"))))) + + (deftest "roundtrip string" + (assert-equal "\"hello\"" (sx-serialize (first (sx-parse "\"hello\""))))) + + (deftest "roundtrip list" + (assert-equal "(1 2 3)" (sx-serialize (first (sx-parse "(1 2 3)"))))) + + (deftest "roundtrip nested" + (assert-equal "(a (b c))" + (sx-serialize (first (sx-parse "(a (b c))")))))) + + +;; -------------------------------------------------------------------------- +;; Reader macros +;; -------------------------------------------------------------------------- + +(defsuite "reader-macros" + (deftest "datum comment discards expr" + (assert-equal (list 42) (sx-parse "#;(ignored) 42"))) + + (deftest "datum comment in list" + (assert-equal (list (list 1 3)) (sx-parse "(1 #;2 3)"))) + + (deftest "datum comment discards nested" + (assert-equal (list 99) (sx-parse "#;(a (b c) d) 99"))) + + (deftest "raw string basic" + (assert-equal (list "hello") (sx-parse "#|hello|"))) + + (deftest "raw string with quotes" + (assert-equal (list "say \"hi\"") (sx-parse "#|say \"hi\"|"))) + + (deftest "raw string with backslashes" + (assert-equal (list "a\\nb") (sx-parse "#|a\\nb|"))) + + (deftest "raw string empty" + (assert-equal (list "") (sx-parse "#||"))) + + (deftest "quote shorthand symbol" + (let ((result (first (sx-parse "#'foo")))) + (assert-equal "quote" (symbol-name (first result))) + (assert-equal "foo" (symbol-name (nth result 1))))) + + (deftest "quote shorthand list" + (let ((result (first (sx-parse "#'(1 2 3)")))) + (assert-equal "quote" (symbol-name (first result))) + (assert-equal (list 1 2 3) (nth result 1))))) diff --git a/spec/test-render.sx b/spec/test-render.sx new file mode 100644 index 0000000..1097d7a --- /dev/null +++ b/spec/test-render.sx @@ -0,0 +1,230 @@ +;; ========================================================================== +;; test-render.sx — Tests for the HTML rendering adapter +;; +;; Requires: test-framework.sx loaded first. +;; Modules tested: render.sx, adapter-html.sx +;; +;; Platform functions required (beyond test framework): +;; render-html (sx-source) -> HTML string +;; Parses the sx-source string, evaluates via render-to-html in a +;; fresh env, and returns the resulting HTML string. +;; (This is a test-only convenience that wraps parse + render-to-html.) +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; Basic element rendering +;; -------------------------------------------------------------------------- + +(defsuite "render-elements" + (deftest "simple div" + (assert-equal "
hello
" + (render-html "(div \"hello\")"))) + + (deftest "nested elements" + (assert-equal "
hi
" + (render-html "(div (span \"hi\"))"))) + + (deftest "multiple children" + (assert-equal "

a

b

" + (render-html "(div (p \"a\") (p \"b\"))"))) + + (deftest "text content" + (assert-equal "

hello world

" + (render-html "(p \"hello\" \" world\")"))) + + (deftest "number content" + (assert-equal "42" + (render-html "(span 42)")))) + + +;; -------------------------------------------------------------------------- +;; Attributes +;; -------------------------------------------------------------------------- + +(defsuite "render-attrs" + (deftest "string attribute" + (let ((html (render-html "(div :id \"main\" \"content\")"))) + (assert-true (string-contains? html "id=\"main\"")) + (assert-true (string-contains? html "content")))) + + (deftest "class attribute" + (let ((html (render-html "(div :class \"foo bar\" \"x\")"))) + (assert-true (string-contains? html "class=\"foo bar\"")))) + + (deftest "multiple attributes" + (let ((html (render-html "(a :href \"/home\" :class \"link\" \"Home\")"))) + (assert-true (string-contains? html "href=\"/home\"")) + (assert-true (string-contains? html "class=\"link\"")) + (assert-true (string-contains? html "Home"))))) + + +;; -------------------------------------------------------------------------- +;; Void elements +;; -------------------------------------------------------------------------- + +(defsuite "render-void" + (deftest "br is self-closing" + (assert-equal "
" (render-html "(br)"))) + + (deftest "img with attrs" + (let ((html (render-html "(img :src \"pic.jpg\" :alt \"A pic\")"))) + (assert-true (string-contains? html "")) + ;; void elements should not have a closing tag + (assert-false (string-contains? html "")))) + + (deftest "input is self-closing" + (let ((html (render-html "(input :type \"text\" :name \"q\")"))) + (assert-true (string-contains? html ""))))) + + +;; -------------------------------------------------------------------------- +;; Boolean attributes +;; -------------------------------------------------------------------------- + +(defsuite "render-boolean-attrs" + (deftest "true boolean attr emits name only" + (let ((html (render-html "(input :disabled true :type \"text\")"))) + (assert-true (string-contains? html "disabled")) + ;; Should NOT have disabled="true" + (assert-false (string-contains? html "disabled=\"")))) + + (deftest "false boolean attr omitted" + (let ((html (render-html "(input :disabled false :type \"text\")"))) + (assert-false (string-contains? html "disabled"))))) + + +;; -------------------------------------------------------------------------- +;; Fragments +;; -------------------------------------------------------------------------- + +(defsuite "render-fragments" + (deftest "fragment renders children without wrapper" + (assert-equal "

a

b

" + (render-html "(<> (p \"a\") (p \"b\"))"))) + + (deftest "empty fragment" + (assert-equal "" + (render-html "(<>)")))) + + +;; -------------------------------------------------------------------------- +;; HTML escaping +;; -------------------------------------------------------------------------- + +(defsuite "render-escaping" + (deftest "text content is escaped" + (let ((html (render-html "(p \"\")"))) + (assert-false (string-contains? html "