From ce7ad125b6e8219ed544f1057b08893429c219f7 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 11 Mar 2026 22:51:19 +0000 Subject: [PATCH 1/4] Add deftype and defeffect to SX type system (Phases 6-7) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Phase 6 — deftype: named type aliases, unions, records, and parameterized types. Type definitions stored as plain dicts in *type-registry*. Includes resolve-type for named type resolution, substitute-type-vars for parameterized instantiation, subtype-resolved? for structural record subtyping, and infer-type extension for record field type inference via get. Phase 7 — defeffect: static effect annotations. Effects stored in *effect-registry* and *effect-annotations*. Supports :effects keyword on defcomp and define. Gradual: unannotated = all effects, empty list = pure. check-body-walk validates effect containment at call sites. Standard types defined: (maybe a), type-def, diagnostic, prim-param-sig. Standard effects declared: io, mutation, render. 84/84 type system tests pass. Both Python and JS bootstrappers succeed. Co-Authored-By: Claude Opus 4.6 --- shared/static/scripts/sx-browser.js | 75 +++++- shared/sx/ref/adapter-async.sx | 7 +- shared/sx/ref/adapter-html.sx | 1 + shared/sx/ref/adapter-sx.sx | 6 +- shared/sx/ref/eval.sx | 116 +++++++++- shared/sx/ref/platform_py.py | 5 + shared/sx/ref/render.sx | 3 +- shared/sx/ref/run_type_tests.py | 180 +++++++++++++++ shared/sx/ref/special-forms.sx | 23 ++ shared/sx/ref/sx_ref.py | 95 +++++++- shared/sx/ref/test-types.sx | 169 +++++++++++++- shared/sx/ref/types.sx | 338 +++++++++++++++++++++++----- 12 files changed, 938 insertions(+), 80 deletions(-) create mode 100644 shared/sx/ref/run_type_tests.py diff --git a/shared/static/scripts/sx-browser.js b/shared/static/scripts/sx-browser.js index f505d9d..73e7704 100644 --- a/shared/static/scripts/sx-browser.js +++ b/shared/static/scripts/sx-browser.js @@ -14,7 +14,7 @@ // ========================================================================= var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } }); - var SX_VERSION = "2026-03-11T21:02:07Z"; + var SX_VERSION = "2026-03-11T22:28:29Z"; function isNil(x) { return x === NIL || x === null || x === undefined; } function isSxTruthy(x) { return x !== false && !isNil(x); } @@ -729,10 +729,10 @@ var args = rest(expr); return (isSxTruthy(!isSxTruthy(sxOr((typeOf(head) == "symbol"), (typeOf(head) == "lambda"), (typeOf(head) == "list")))) ? map(function(x) { return trampoline(evalExpr(x, env)); }, expr) : (isSxTruthy((typeOf(head) == "symbol")) ? (function() { var name = symbolName(head); - return (isSxTruthy((name == "if")) ? sfIf(args, env) : (isSxTruthy((name == "when")) ? sfWhen(args, env) : (isSxTruthy((name == "cond")) ? sfCond(args, env) : (isSxTruthy((name == "case")) ? sfCase(args, env) : (isSxTruthy((name == "and")) ? sfAnd(args, env) : (isSxTruthy((name == "or")) ? sfOr(args, env) : (isSxTruthy((name == "let")) ? sfLet(args, env) : (isSxTruthy((name == "let*")) ? sfLet(args, env) : (isSxTruthy((name == "letrec")) ? sfLetrec(args, env) : (isSxTruthy((name == "lambda")) ? sfLambda(args, env) : (isSxTruthy((name == "fn")) ? sfLambda(args, env) : (isSxTruthy((name == "define")) ? sfDefine(args, env) : (isSxTruthy((name == "defcomp")) ? sfDefcomp(args, env) : (isSxTruthy((name == "defisland")) ? sfDefisland(args, env) : (isSxTruthy((name == "defmacro")) ? sfDefmacro(args, env) : (isSxTruthy((name == "defstyle")) ? sfDefstyle(args, env) : (isSxTruthy((name == "defhandler")) ? sfDefhandler(args, env) : (isSxTruthy((name == "defpage")) ? sfDefpage(args, env) : (isSxTruthy((name == "defquery")) ? sfDefquery(args, env) : (isSxTruthy((name == "defaction")) ? sfDefaction(args, env) : (isSxTruthy((name == "begin")) ? sfBegin(args, env) : (isSxTruthy((name == "do")) ? sfBegin(args, env) : (isSxTruthy((name == "quote")) ? sfQuote(args, env) : (isSxTruthy((name == "quasiquote")) ? sfQuasiquote(args, env) : (isSxTruthy((name == "->")) ? sfThreadFirst(args, env) : (isSxTruthy((name == "set!")) ? sfSetBang(args, env) : (isSxTruthy((name == "reset")) ? sfReset(args, env) : (isSxTruthy((name == "shift")) ? sfShift(args, env) : (isSxTruthy((name == "dynamic-wind")) ? sfDynamicWind(args, env) : (isSxTruthy((name == "map")) ? hoMap(args, env) : (isSxTruthy((name == "map-indexed")) ? hoMapIndexed(args, env) : (isSxTruthy((name == "filter")) ? hoFilter(args, env) : (isSxTruthy((name == "reduce")) ? hoReduce(args, env) : (isSxTruthy((name == "some")) ? hoSome(args, env) : (isSxTruthy((name == "every?")) ? hoEvery(args, env) : (isSxTruthy((name == "for-each")) ? hoForEach(args, env) : (isSxTruthy((isSxTruthy(envHas(env, name)) && isMacro(envGet(env, name)))) ? (function() { + return (isSxTruthy((name == "if")) ? sfIf(args, env) : (isSxTruthy((name == "when")) ? sfWhen(args, env) : (isSxTruthy((name == "cond")) ? sfCond(args, env) : (isSxTruthy((name == "case")) ? sfCase(args, env) : (isSxTruthy((name == "and")) ? sfAnd(args, env) : (isSxTruthy((name == "or")) ? sfOr(args, env) : (isSxTruthy((name == "let")) ? sfLet(args, env) : (isSxTruthy((name == "let*")) ? sfLet(args, env) : (isSxTruthy((name == "letrec")) ? sfLetrec(args, env) : (isSxTruthy((name == "lambda")) ? sfLambda(args, env) : (isSxTruthy((name == "fn")) ? sfLambda(args, env) : (isSxTruthy((name == "define")) ? sfDefine(args, env) : (isSxTruthy((name == "defcomp")) ? sfDefcomp(args, env) : (isSxTruthy((name == "defisland")) ? sfDefisland(args, env) : (isSxTruthy((name == "defmacro")) ? sfDefmacro(args, env) : (isSxTruthy((name == "defstyle")) ? sfDefstyle(args, env) : (isSxTruthy((name == "defhandler")) ? sfDefhandler(args, env) : (isSxTruthy((name == "defpage")) ? sfDefpage(args, env) : (isSxTruthy((name == "defquery")) ? sfDefquery(args, env) : (isSxTruthy((name == "defaction")) ? sfDefaction(args, env) : (isSxTruthy((name == "deftype")) ? sfDeftype(args, env) : (isSxTruthy((name == "defeffect")) ? sfDefeffect(args, env) : (isSxTruthy((name == "begin")) ? sfBegin(args, env) : (isSxTruthy((name == "do")) ? sfBegin(args, env) : (isSxTruthy((name == "quote")) ? sfQuote(args, env) : (isSxTruthy((name == "quasiquote")) ? sfQuasiquote(args, env) : (isSxTruthy((name == "->")) ? sfThreadFirst(args, env) : (isSxTruthy((name == "set!")) ? sfSetBang(args, env) : (isSxTruthy((name == "reset")) ? sfReset(args, env) : (isSxTruthy((name == "shift")) ? sfShift(args, env) : (isSxTruthy((name == "dynamic-wind")) ? sfDynamicWind(args, env) : (isSxTruthy((name == "map")) ? hoMap(args, env) : (isSxTruthy((name == "map-indexed")) ? hoMapIndexed(args, env) : (isSxTruthy((name == "filter")) ? hoFilter(args, env) : (isSxTruthy((name == "reduce")) ? hoReduce(args, env) : (isSxTruthy((name == "some")) ? hoSome(args, env) : (isSxTruthy((name == "every?")) ? hoEvery(args, env) : (isSxTruthy((name == "for-each")) ? hoForEach(args, env) : (isSxTruthy((isSxTruthy(envHas(env, name)) && isMacro(envGet(env, name)))) ? (function() { var mac = envGet(env, name); return makeThunk(expandMacro(mac, args, env), env); -})() : (isSxTruthy((isSxTruthy(renderActiveP()) && isRenderExpr(expr))) ? renderExpr(expr, env) : evalCall(head, args, env))))))))))))))))))))))))))))))))))))))); +})() : (isSxTruthy((isSxTruthy(renderActiveP()) && isRenderExpr(expr))) ? renderExpr(expr, env) : evalCall(head, args, env))))))))))))))))))))))))))))))))))))))))); })() : evalCall(head, args, env))); })(); }; @@ -888,11 +888,22 @@ return append_b(inits, nth(binding, 1)); }, bindings) : reduce(function(acc, pai // sf-define var sfDefine = function(args, env) { return (function() { var nameSym = first(args); - var value = trampoline(evalExpr(nth(args, 1), env)); + var hasEffects = (isSxTruthy((len(args) >= 4)) && isSxTruthy((typeOf(nth(args, 1)) == "keyword")) && (keywordName(nth(args, 1)) == "effects")); + var valIdx = (isSxTruthy((isSxTruthy((len(args) >= 4)) && isSxTruthy((typeOf(nth(args, 1)) == "keyword")) && (keywordName(nth(args, 1)) == "effects"))) ? 3 : 1); + var value = trampoline(evalExpr(nth(args, valIdx), env)); if (isSxTruthy((isSxTruthy(isLambda(value)) && isNil(lambdaName(value))))) { value.name = symbolName(nameSym); } envSet(env, symbolName(nameSym), value); + if (isSxTruthy(hasEffects)) { + (function() { + var effectsRaw = nth(args, 2); + var effectList = (isSxTruthy((typeOf(effectsRaw) == "list")) ? map(function(e) { return (isSxTruthy((typeOf(e) == "symbol")) ? symbolName(e) : (String(e))); }, effectsRaw) : [(String(effectsRaw))]); + var effectAnns = (isSxTruthy(envHas(env, "*effect-annotations*")) ? envGet(env, "*effect-annotations*") : {}); + effectAnns[symbolName(nameSym)] = effectList; + return envSet(env, "*effect-annotations*", effectAnns); +})(); +} return value; })(); }; @@ -909,8 +920,17 @@ return append_b(inits, nth(binding, 1)); }, bindings) : reduce(function(acc, pai var affinity = defcompKwarg(args, "affinity", "auto"); return (function() { var comp = makeComponent(compName, params, hasChildren, body, env, affinity); + var effects = defcompKwarg(args, "effects", NIL); if (isSxTruthy((isSxTruthy(!isSxTruthy(isNil(paramTypes))) && !isSxTruthy(isEmpty(keys(paramTypes)))))) { componentSetParamTypes_b(comp, paramTypes); +} + if (isSxTruthy(!isSxTruthy(isNil(effects)))) { + (function() { + var effectList = (isSxTruthy((typeOf(effects) == "list")) ? map(function(e) { return (isSxTruthy((typeOf(e) == "symbol")) ? symbolName(e) : (String(e))); }, effects) : [(String(effects))]); + var effectAnns = (isSxTruthy(envHas(env, "*effect-annotations*")) ? envGet(env, "*effect-annotations*") : {}); + effectAnns[symbolName(nameSym)] = effectList; + return envSet(env, "*effect-annotations*", effectAnns); +})(); } envSet(env, symbolName(nameSym), comp); return comp; @@ -997,6 +1017,45 @@ return append_b(inits, nth(binding, 1)); }, bindings) : reduce(function(acc, pai return value; })(); }; + // make-type-def + var makeTypeDef = function(name, params, body) { return {"name": name, "params": params, "body": body}; }; + + // normalize-type-body + var normalizeTypeBody = function(body) { return (isSxTruthy(isNil(body)) ? "nil" : (isSxTruthy((typeOf(body) == "symbol")) ? symbolName(body) : (isSxTruthy((typeOf(body) == "string")) ? body : (isSxTruthy((typeOf(body) == "keyword")) ? keywordName(body) : (isSxTruthy((typeOf(body) == "dict")) ? mapDict(function(k, v) { return normalizeTypeBody(v); }, body) : (isSxTruthy((typeOf(body) == "list")) ? (isSxTruthy(isEmpty(body)) ? "any" : (function() { + var head = first(body); + return (function() { + var headName = (isSxTruthy((typeOf(head) == "symbol")) ? symbolName(head) : (String(head))); + return (isSxTruthy((headName == "union")) ? cons("or", map(normalizeTypeBody, rest(body))) : cons(headName, map(normalizeTypeBody, rest(body)))); +})(); +})()) : (String(body)))))))); }; + + // sf-deftype + var sfDeftype = function(args, env) { return (function() { + var nameOrForm = first(args); + var bodyExpr = nth(args, 1); + var typeName = NIL; + var typeParams = []; + (isSxTruthy((typeOf(nameOrForm) == "symbol")) ? (typeName = symbolName(nameOrForm)) : (isSxTruthy((typeOf(nameOrForm) == "list")) ? ((typeName = symbolName(first(nameOrForm))), (typeParams = map(function(p) { return (isSxTruthy((typeOf(p) == "symbol")) ? symbolName(p) : (String(p))); }, rest(nameOrForm)))) : NIL)); + return (function() { + var body = normalizeTypeBody(bodyExpr); + var registry = (isSxTruthy(envHas(env, "*type-registry*")) ? envGet(env, "*type-registry*") : {}); + registry[typeName] = makeTypeDef(typeName, typeParams, body); + envSet(env, "*type-registry*", registry); + return NIL; +})(); +})(); }; + + // sf-defeffect + var sfDefeffect = function(args, env) { return (function() { + var effectName = (isSxTruthy((typeOf(first(args)) == "symbol")) ? symbolName(first(args)) : (String(first(args)))); + var registry = (isSxTruthy(envHas(env, "*effect-registry*")) ? envGet(env, "*effect-registry*") : []); + if (isSxTruthy(!isSxTruthy(contains(registry, effectName)))) { + registry.push(effectName); +} + envSet(env, "*effect-registry*", registry); + return NIL; +})(); }; + // sf-begin var sfBegin = function(args, env) { return (isSxTruthy(isEmpty(args)) ? NIL : (forEach(function(e) { return trampoline(evalExpr(e, env)); }, slice(args, 0, (len(args) - 1))), makeThunk(last(args), env))); }; @@ -1156,7 +1215,7 @@ return append_b(inits, nth(binding, 1)); }, bindings) : reduce(function(acc, pai var BOOLEAN_ATTRS = ["async", "autofocus", "autoplay", "checked", "controls", "default", "defer", "disabled", "formnovalidate", "hidden", "inert", "ismap", "loop", "multiple", "muted", "nomodule", "novalidate", "open", "playsinline", "readonly", "required", "reversed", "selected"]; // definition-form? - var isDefinitionForm = function(name) { return sxOr((name == "define"), (name == "defcomp"), (name == "defisland"), (name == "defmacro"), (name == "defstyle"), (name == "defhandler")); }; + var isDefinitionForm = function(name) { return sxOr((name == "define"), (name == "defcomp"), (name == "defisland"), (name == "defmacro"), (name == "defstyle"), (name == "defhandler"), (name == "deftype"), (name == "defeffect")); }; // parse-element-args var parseElementArgs = function(args, env) { return (function() { @@ -1366,7 +1425,7 @@ return (function() { var _m = typeOf(expr); if (_m == "nil") return ""; if (_m = var renderValueToHtml = function(val, env) { return (function() { var _m = typeOf(val); if (_m == "nil") return ""; if (_m == "string") return escapeHtml(val); if (_m == "number") return (String(val)); if (_m == "boolean") return (isSxTruthy(val) ? "true" : "false"); if (_m == "list") return renderListToHtml(val, env); if (_m == "raw-html") return rawHtmlContent(val); return escapeHtml((String(val))); })(); }; // RENDER_HTML_FORMS - var RENDER_HTML_FORMS = ["if", "when", "cond", "case", "let", "let*", "begin", "do", "define", "defcomp", "defisland", "defmacro", "defstyle", "defhandler", "map", "map-indexed", "filter", "for-each"]; + var RENDER_HTML_FORMS = ["if", "when", "cond", "case", "let", "let*", "begin", "do", "define", "defcomp", "defisland", "defmacro", "defstyle", "defhandler", "deftype", "defeffect", "map", "map-indexed", "filter", "for-each"]; // render-html-form? var isRenderHtmlForm = function(name) { return contains(RENDER_HTML_FORMS, name); }; @@ -1574,7 +1633,7 @@ return (function() { var _m = typeOf(expr); if (_m == "number") return expr; if })(); }; // SPECIAL_FORM_NAMES - var SPECIAL_FORM_NAMES = ["if", "when", "cond", "case", "and", "or", "let", "let*", "lambda", "fn", "define", "defcomp", "defmacro", "defstyle", "defhandler", "defpage", "defquery", "defaction", "defrelation", "begin", "do", "quote", "quasiquote", "->", "set!", "letrec", "dynamic-wind", "defisland"]; + var SPECIAL_FORM_NAMES = ["if", "when", "cond", "case", "and", "or", "let", "let*", "lambda", "fn", "define", "defcomp", "defmacro", "defstyle", "defhandler", "defpage", "defquery", "defaction", "defrelation", "begin", "do", "quote", "quasiquote", "->", "set!", "letrec", "dynamic-wind", "defisland", "deftype", "defeffect"]; // HO_FORM_NAMES var HO_FORM_NAMES = ["map", "map-indexed", "filter", "reduce", "some", "every?", "for-each"]; @@ -1645,7 +1704,7 @@ return result; }, args); return append_b(results, aser(lambdaBody(f), local)); })() : invoke(f, item)); } } return (isSxTruthy(isEmpty(results)) ? NIL : results); -})() : (isSxTruthy((name == "defisland")) ? (trampoline(evalExpr(expr, env)), serialize(expr)) : (isSxTruthy(sxOr((name == "define"), (name == "defcomp"), (name == "defmacro"), (name == "defstyle"), (name == "defhandler"), (name == "defpage"), (name == "defquery"), (name == "defaction"), (name == "defrelation"))) ? (trampoline(evalExpr(expr, env)), NIL) : trampoline(evalExpr(expr, env))))))))))))))); +})() : (isSxTruthy((name == "defisland")) ? (trampoline(evalExpr(expr, env)), serialize(expr)) : (isSxTruthy(sxOr((name == "define"), (name == "defcomp"), (name == "defmacro"), (name == "defstyle"), (name == "defhandler"), (name == "defpage"), (name == "defquery"), (name == "defaction"), (name == "defrelation"), (name == "deftype"), (name == "defeffect"))) ? (trampoline(evalExpr(expr, env)), NIL) : trampoline(evalExpr(expr, env))))))))))))))); })(); }; // eval-case-aser diff --git a/shared/sx/ref/adapter-async.sx b/shared/sx/ref/adapter-async.sx index cfcce1b..09803f3 100644 --- a/shared/sx/ref/adapter-async.sx +++ b/shared/sx/ref/adapter-async.sx @@ -316,6 +316,7 @@ (define ASYNC_RENDER_FORMS (list "if" "when" "cond" "case" "let" "let*" "begin" "do" "define" "defcomp" "defisland" "defmacro" "defstyle" "defhandler" + "deftype" "defeffect" "map" "map-indexed" "filter" "for-each")) (define async-render-form? @@ -853,7 +854,8 @@ "let" "let*" "lambda" "fn" "define" "defcomp" "defmacro" "defstyle" "defhandler" "defpage" "defquery" "defaction" - "begin" "do" "quote" "->" "set!" "defisland")) + "begin" "do" "quote" "->" "set!" "defisland" + "deftype" "defeffect")) (define ASYNC_ASER_HO_NAMES (list "map" "map-indexed" "filter" "for-each")) @@ -987,7 +989,8 @@ ;; Definition forms — evaluate for side effects (or (= name "define") (= name "defcomp") (= name "defmacro") (= name "defstyle") (= name "defhandler") (= name "defpage") - (= name "defquery") (= name "defaction")) + (= name "defquery") (= name "defaction") + (= name "deftype") (= name "defeffect")) (do (async-eval expr env ctx) nil) ;; Fallback diff --git a/shared/sx/ref/adapter-html.sx b/shared/sx/ref/adapter-html.sx index 306baaf..fa44e2d 100644 --- a/shared/sx/ref/adapter-html.sx +++ b/shared/sx/ref/adapter-html.sx @@ -52,6 +52,7 @@ (define RENDER_HTML_FORMS (list "if" "when" "cond" "case" "let" "let*" "begin" "do" "define" "defcomp" "defisland" "defmacro" "defstyle" "defhandler" + "deftype" "defeffect" "map" "map-indexed" "filter" "for-each")) (define render-html-form? diff --git a/shared/sx/ref/adapter-sx.sx b/shared/sx/ref/adapter-sx.sx index 2979ecb..ddd4321 100644 --- a/shared/sx/ref/adapter-sx.sx +++ b/shared/sx/ref/adapter-sx.sx @@ -170,7 +170,8 @@ "define" "defcomp" "defmacro" "defstyle" "defhandler" "defpage" "defquery" "defaction" "defrelation" "begin" "do" "quote" "quasiquote" - "->" "set!" "letrec" "dynamic-wind" "defisland")) + "->" "set!" "letrec" "dynamic-wind" "defisland" + "deftype" "defeffect")) (define HO_FORM_NAMES (list "map" "map-indexed" "filter" "reduce" @@ -304,7 +305,8 @@ ;; Definition forms — evaluate for side effects (or (= name "define") (= name "defcomp") (= name "defmacro") (= name "defstyle") (= name "defhandler") (= name "defpage") - (= name "defquery") (= name "defaction") (= name "defrelation")) + (= name "defquery") (= name "defaction") (= name "defrelation") + (= name "deftype") (= name "defeffect")) (do (trampoline (eval-expr expr env)) nil) ;; Everything else — evaluate normally diff --git a/shared/sx/ref/eval.sx b/shared/sx/ref/eval.sx index 8cad009..2c3717c 100644 --- a/shared/sx/ref/eval.sx +++ b/shared/sx/ref/eval.sx @@ -151,6 +151,8 @@ (= 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) @@ -506,11 +508,32 @@ (define sf-define (fn ((args :as list) (env :as dict)) + ;; Detect :effects keyword: (define name :effects [...] value) (let ((name-sym (first args)) - (value (trampoline (eval-expr (nth args 1) env)))) + (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))) @@ -528,11 +551,24 @@ (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))) + (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)))) @@ -654,6 +690,82 @@ 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) diff --git a/shared/sx/ref/platform_py.py b/shared/sx/ref/platform_py.py index e2ccec0..e596a34 100644 --- a/shared/sx/ref/platform_py.py +++ b/shared/sx/ref/platform_py.py @@ -575,6 +575,11 @@ def strip_prefix(s, prefix): return s[len(prefix):] if s.startswith(prefix) else s +def debug_log(*args): + import sys + print(*args, file=sys.stderr) + + def error(msg): raise EvalError(msg) diff --git a/shared/sx/ref/render.sx b/shared/sx/ref/render.sx index be53226..7624f9b 100644 --- a/shared/sx/ref/render.sx +++ b/shared/sx/ref/render.sx @@ -74,7 +74,8 @@ (define definition-form? (fn ((name :as string)) (or (= name "define") (= name "defcomp") (= name "defisland") - (= name "defmacro") (= name "defstyle") (= name "defhandler")))) + (= name "defmacro") (= name "defstyle") (= name "defhandler") + (= name "deftype") (= name "defeffect")))) (define parse-element-args diff --git a/shared/sx/ref/run_type_tests.py b/shared/sx/ref/run_type_tests.py new file mode 100644 index 0000000..d3f4021 --- /dev/null +++ b/shared/sx/ref/run_type_tests.py @@ -0,0 +1,180 @@ +#!/usr/bin/env python3 +"""Run test-types.sx using the bootstrapped evaluator with types module loaded.""" +from __future__ import annotations +import os, sys + +_HERE = os.path.dirname(os.path.abspath(__file__)) +_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", "..")) +sys.path.insert(0, _PROJECT) + +from shared.sx.parser import parse_all +from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env +from shared.sx.types import NIL, Component + +# Build env with primitives +env = make_env() + +# Platform test functions +_suite_stack: list[str] = [] +_pass_count = 0 +_fail_count = 0 + +def _try_call(thunk): + try: + trampoline(eval_expr([thunk], env)) # call the thunk + return {"ok": True} + except Exception as e: + return {"ok": False, "error": str(e)} + +def _report_pass(name): + global _pass_count + _pass_count += 1 + ctx = " > ".join(_suite_stack) + print(f" PASS: {ctx} > {name}") + return NIL + +def _report_fail(name, error): + global _fail_count + _fail_count += 1 + ctx = " > ".join(_suite_stack) + print(f" FAIL: {ctx} > {name}: {error}") + return NIL + +def _push_suite(name): + _suite_stack.append(name) + print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}") + return NIL + +def _pop_suite(): + if _suite_stack: + _suite_stack.pop() + return NIL + +env["try-call"] = _try_call +env["report-pass"] = _report_pass +env["report-fail"] = _report_fail +env["push-suite"] = _push_suite +env["pop-suite"] = _pop_suite + +# Test fixtures — provide the functions that tests expect + +# test-prim-types: dict of primitive return types for type inference +def _test_prim_types(): + return { + "+": "number", "-": "number", "*": "number", "/": "number", + "mod": "number", "inc": "number", "dec": "number", + "abs": "number", "min": "number", "max": "number", + "floor": "number", "ceil": "number", "round": "number", + "str": "string", "upper": "string", "lower": "string", + "trim": "string", "join": "string", "replace": "string", + "format": "string", "substr": "string", + "=": "boolean", "<": "boolean", ">": "boolean", + "<=": "boolean", ">=": "boolean", "!=": "boolean", + "not": "boolean", "nil?": "boolean", "empty?": "boolean", + "number?": "boolean", "string?": "boolean", "boolean?": "boolean", + "list?": "boolean", "dict?": "boolean", "symbol?": "boolean", + "keyword?": "boolean", "contains?": "boolean", "has-key?": "boolean", + "starts-with?": "boolean", "ends-with?": "boolean", + "len": "number", "first": "any", "rest": "list", + "last": "any", "nth": "any", "cons": "list", + "append": "list", "concat": "list", "reverse": "list", + "sort": "list", "slice": "list", "range": "list", + "flatten": "list", "keys": "list", "vals": "list", + "map-dict": "dict", "assoc": "dict", "dissoc": "dict", + "merge": "dict", "dict": "dict", + "get": "any", "type-of": "string", + } + +# test-prim-param-types: dict of primitive param type specs +# Format: {name → {"positional" [["name" "type"] ...] "rest-type" type-or-nil}} +def _test_prim_param_types(): + return { + "+": {"positional": [["a", "number"]], "rest-type": "number"}, + "-": {"positional": [["a", "number"]], "rest-type": "number"}, + "*": {"positional": [["a", "number"]], "rest-type": "number"}, + "/": {"positional": [["a", "number"]], "rest-type": "number"}, + "inc": {"positional": [["n", "number"]], "rest-type": NIL}, + "dec": {"positional": [["n", "number"]], "rest-type": NIL}, + "upper": {"positional": [["s", "string"]], "rest-type": NIL}, + "lower": {"positional": [["s", "string"]], "rest-type": NIL}, + "keys": {"positional": [["d", "dict"]], "rest-type": NIL}, + "vals": {"positional": [["d", "dict"]], "rest-type": NIL}, + } + +# test-env: returns a fresh env for use in tests (same as the test env) +def _test_env(): + return env + +# sx-parse: parse an SX string and return list of AST nodes +def _sx_parse(source): + return parse_all(source) + +# dict-get: used in some legacy tests +def _dict_get(d, k): + v = d.get(k) if isinstance(d, dict) else NIL + return v if v is not None else NIL + +# component-set-param-types! and component-param-types: type annotation accessors +def _component_set_param_types(comp, types_dict): + comp.param_types = types_dict + return NIL + +def _component_param_types(comp): + return getattr(comp, 'param_types', NIL) + +# Platform functions used by types.sx but not SX primitives +def _component_params(c): + return c.params + +def _component_body(c): + return c.body + +def _component_has_children(c): + return c.has_children + +def _map_dict(fn, d): + from shared.sx.types import Lambda as _Lambda + result = {} + for k, v in d.items(): + if isinstance(fn, _Lambda): + # Call SX lambda through the evaluator + result[k] = trampoline(eval_expr([fn, k, v], env)) + else: + result[k] = fn(k, v) + return result + +env["test-prim-types"] = _test_prim_types +env["test-prim-param-types"] = _test_prim_param_types +env["test-env"] = _test_env +env["sx-parse"] = _sx_parse +env["dict-get"] = _dict_get +env["component-set-param-types!"] = _component_set_param_types +env["component-param-types"] = _component_param_types +env["component-params"] = _component_params +env["component-body"] = _component_body +env["component-has-children"] = _component_has_children +env["map-dict"] = _map_dict + +# Load test framework (macros + assertion helpers) +with open(os.path.join(_HERE, "test-framework.sx")) as f: + for expr in parse_all(f.read()): + trampoline(eval_expr(expr, env)) + +# Load types module +with open(os.path.join(_HERE, "types.sx")) as f: + for expr in parse_all(f.read()): + trampoline(eval_expr(expr, env)) + +# Run tests +print("=" * 60) +print("Running test-types.sx") +print("=" * 60) + +with open(os.path.join(_HERE, "test-types.sx")) as f: + for expr in parse_all(f.read()): + trampoline(eval_expr(expr, env)) + +print("=" * 60) +print(f"Results: {_pass_count} passed, {_fail_count} failed") +print("=" * 60) +sys.exit(1 if _fail_count > 0 else 0) diff --git a/shared/sx/ref/special-forms.sx b/shared/sx/ref/special-forms.sx index 05bede7..8c880af 100644 --- a/shared/sx/ref/special-forms.sx +++ b/shared/sx/ref/special-forms.sx @@ -209,6 +209,29 @@ :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 diff --git a/shared/sx/ref/sx_ref.py b/shared/sx/ref/sx_ref.py index 71cee96..6a0e5fe 100644 --- a/shared/sx/ref/sx_ref.py +++ b/shared/sx/ref/sx_ref.py @@ -534,6 +534,11 @@ def strip_prefix(s, prefix): return s[len(prefix):] if s.startswith(prefix) else s +def debug_log(*args): + import sys + print(*args, file=sys.stderr) + + def error(msg): raise EvalError(msg) @@ -1255,6 +1260,10 @@ def eval_list(expr, env): return sf_defquery(args, env) elif sx_truthy((name == 'defaction')): return sf_defaction(args, env) + elif sx_truthy((name == 'deftype')): + return sf_deftype(args, env) + elif sx_truthy((name == 'defeffect')): + return sf_defeffect(args, env) elif sx_truthy((name == 'begin')): return sf_begin(args, env) elif sx_truthy((name == 'do')): @@ -1504,10 +1513,18 @@ def sf_lambda(args, env): # sf-define def sf_define(args, env): name_sym = first(args) - value = trampoline(eval_expr(nth(args, 1), env)) + has_effects = ((len(args) >= 4) if not sx_truthy((len(args) >= 4)) else ((type_of(nth(args, 1)) == 'keyword') if not sx_truthy((type_of(nth(args, 1)) == 'keyword')) else (keyword_name(nth(args, 1)) == 'effects'))) + val_idx = (3 if sx_truthy(((len(args) >= 4) if not sx_truthy((len(args) >= 4)) else ((type_of(nth(args, 1)) == 'keyword') if not sx_truthy((type_of(nth(args, 1)) == 'keyword')) else (keyword_name(nth(args, 1)) == 'effects')))) else 1) + value = trampoline(eval_expr(nth(args, val_idx), env)) if sx_truthy((is_lambda(value) if not sx_truthy(is_lambda(value)) else is_nil(lambda_name(value)))): value.name = symbol_name(name_sym) env[symbol_name(name_sym)] = value + if sx_truthy(has_effects): + effects_raw = nth(args, 2) + effect_list = (map(lambda e: (symbol_name(e) if sx_truthy((type_of(e) == 'symbol')) else sx_str(e)), effects_raw) if sx_truthy((type_of(effects_raw) == 'list')) else [sx_str(effects_raw)]) + effect_anns = (env_get(env, '*effect-annotations*') if sx_truthy(env_has(env, '*effect-annotations*')) else {}) + effect_anns[symbol_name(name_sym)] = effect_list + env['*effect-annotations*'] = effect_anns return value # sf-defcomp @@ -1522,8 +1539,14 @@ def sf_defcomp(args, env): param_types = nth(parsed, 2) affinity = defcomp_kwarg(args, 'affinity', 'auto') comp = make_component(comp_name, params, has_children, body, env, affinity) + effects = defcomp_kwarg(args, 'effects', NIL) if sx_truthy(((not sx_truthy(is_nil(param_types))) if not sx_truthy((not sx_truthy(is_nil(param_types)))) else (not sx_truthy(empty_p(keys(param_types)))))): component_set_param_types(comp, param_types) + if sx_truthy((not sx_truthy(is_nil(effects)))): + effect_list = (map(lambda e: (symbol_name(e) if sx_truthy((type_of(e) == 'symbol')) else sx_str(e)), effects) if sx_truthy((type_of(effects) == 'list')) else [sx_str(effects)]) + effect_anns = (env_get(env, '*effect-annotations*') if sx_truthy(env_has(env, '*effect-annotations*')) else {}) + effect_anns[symbol_name(name_sym)] = effect_list + env['*effect-annotations*'] = effect_anns env[symbol_name(name_sym)] = comp return comp @@ -1610,6 +1633,62 @@ def sf_defstyle(args, env): env[symbol_name(name_sym)] = value return value +# make-type-def +def make_type_def(name, params, body): + return {'name': name, 'params': params, 'body': body} + +# normalize-type-body +def normalize_type_body(body): + if sx_truthy(is_nil(body)): + return 'nil' + elif sx_truthy((type_of(body) == 'symbol')): + return symbol_name(body) + elif sx_truthy((type_of(body) == 'string')): + return body + elif sx_truthy((type_of(body) == 'keyword')): + return keyword_name(body) + elif sx_truthy((type_of(body) == 'dict')): + return map_dict(lambda k, v: normalize_type_body(v), body) + elif sx_truthy((type_of(body) == 'list')): + if sx_truthy(empty_p(body)): + return 'any' + else: + head = first(body) + head_name = (symbol_name(head) if sx_truthy((type_of(head) == 'symbol')) else sx_str(head)) + if sx_truthy((head_name == 'union')): + return cons('or', map(normalize_type_body, rest(body))) + else: + return cons(head_name, map(normalize_type_body, rest(body))) + else: + return sx_str(body) + +# sf-deftype +def sf_deftype(args, env): + name_or_form = first(args) + body_expr = nth(args, 1) + type_name = NIL + type_params = [] + if sx_truthy((type_of(name_or_form) == 'symbol')): + type_name = symbol_name(name_or_form) + else: + if sx_truthy((type_of(name_or_form) == 'list')): + type_name = symbol_name(first(name_or_form)) + type_params = map(lambda p: (symbol_name(p) if sx_truthy((type_of(p) == 'symbol')) else sx_str(p)), rest(name_or_form)) + body = normalize_type_body(body_expr) + registry = (env_get(env, '*type-registry*') if sx_truthy(env_has(env, '*type-registry*')) else {}) + registry[type_name] = make_type_def(type_name, type_params, body) + env['*type-registry*'] = registry + return NIL + +# sf-defeffect +def sf_defeffect(args, env): + effect_name = (symbol_name(first(args)) if sx_truthy((type_of(first(args)) == 'symbol')) else sx_str(first(args))) + registry = (env_get(env, '*effect-registry*') if sx_truthy(env_has(env, '*effect-registry*')) else []) + if sx_truthy((not sx_truthy(contains_p(registry, effect_name)))): + registry.append(effect_name) + env['*effect-registry*'] = registry + return NIL + # sf-begin def sf_begin(args, env): if sx_truthy(empty_p(args)): @@ -1869,7 +1948,7 @@ BOOLEAN_ATTRS = ['async', 'autofocus', 'autoplay', 'checked', 'controls', 'defau # definition-form? def is_definition_form(name): - return ((name == 'define') if sx_truthy((name == 'define')) else ((name == 'defcomp') if sx_truthy((name == 'defcomp')) else ((name == 'defisland') if sx_truthy((name == 'defisland')) else ((name == 'defmacro') if sx_truthy((name == 'defmacro')) else ((name == 'defstyle') if sx_truthy((name == 'defstyle')) else (name == 'defhandler')))))) + return ((name == 'define') if sx_truthy((name == 'define')) else ((name == 'defcomp') if sx_truthy((name == 'defcomp')) else ((name == 'defisland') if sx_truthy((name == 'defisland')) else ((name == 'defmacro') if sx_truthy((name == 'defmacro')) else ((name == 'defstyle') if sx_truthy((name == 'defstyle')) else ((name == 'defhandler') if sx_truthy((name == 'defhandler')) else ((name == 'deftype') if sx_truthy((name == 'deftype')) else (name == 'defeffect')))))))) # parse-element-args def parse_element_args(args, env): @@ -1995,7 +2074,7 @@ def render_value_to_html(val, env): return escape_html(sx_str(val)) # RENDER_HTML_FORMS -RENDER_HTML_FORMS = ['if', 'when', 'cond', 'case', 'let', 'let*', 'begin', 'do', 'define', 'defcomp', 'defisland', 'defmacro', 'defstyle', 'defhandler', 'map', 'map-indexed', 'filter', 'for-each'] +RENDER_HTML_FORMS = ['if', 'when', 'cond', 'case', 'let', 'let*', 'begin', 'do', 'define', 'defcomp', 'defisland', 'defmacro', 'defstyle', 'defhandler', 'deftype', 'defeffect', 'map', 'map-indexed', 'filter', 'for-each'] # render-html-form? def is_render_html_form(name): @@ -2285,7 +2364,7 @@ def aser_call(name, args, env): return sx_str('(', join(' ', parts), ')') # SPECIAL_FORM_NAMES -SPECIAL_FORM_NAMES = ['if', 'when', 'cond', 'case', 'and', 'or', 'let', 'let*', 'lambda', 'fn', 'define', 'defcomp', 'defmacro', 'defstyle', 'defhandler', 'defpage', 'defquery', 'defaction', 'defrelation', 'begin', 'do', 'quote', 'quasiquote', '->', 'set!', 'letrec', 'dynamic-wind', 'defisland'] +SPECIAL_FORM_NAMES = ['if', 'when', 'cond', 'case', 'and', 'or', 'let', 'let*', 'lambda', 'fn', 'define', 'defcomp', 'defmacro', 'defstyle', 'defhandler', 'defpage', 'defquery', 'defaction', 'defrelation', 'begin', 'do', 'quote', 'quasiquote', '->', 'set!', 'letrec', 'dynamic-wind', 'defisland', 'deftype', 'defeffect'] # HO_FORM_NAMES HO_FORM_NAMES = ['map', 'map-indexed', 'filter', 'reduce', 'some', 'every?', 'for-each'] @@ -2379,7 +2458,7 @@ def aser_special(name, expr, env): elif sx_truthy((name == 'defisland')): trampoline(eval_expr(expr, env)) return serialize(expr) - elif sx_truthy(((name == 'define') if sx_truthy((name == 'define')) else ((name == 'defcomp') if sx_truthy((name == 'defcomp')) else ((name == 'defmacro') if sx_truthy((name == 'defmacro')) else ((name == 'defstyle') if sx_truthy((name == 'defstyle')) else ((name == 'defhandler') if sx_truthy((name == 'defhandler')) else ((name == 'defpage') if sx_truthy((name == 'defpage')) else ((name == 'defquery') if sx_truthy((name == 'defquery')) else ((name == 'defaction') if sx_truthy((name == 'defaction')) else (name == 'defrelation')))))))))): + elif sx_truthy(((name == 'define') if sx_truthy((name == 'define')) else ((name == 'defcomp') if sx_truthy((name == 'defcomp')) else ((name == 'defmacro') if sx_truthy((name == 'defmacro')) else ((name == 'defstyle') if sx_truthy((name == 'defstyle')) else ((name == 'defhandler') if sx_truthy((name == 'defhandler')) else ((name == 'defpage') if sx_truthy((name == 'defpage')) else ((name == 'defquery') if sx_truthy((name == 'defquery')) else ((name == 'defaction') if sx_truthy((name == 'defaction')) else ((name == 'defrelation') if sx_truthy((name == 'defrelation')) else ((name == 'deftype') if sx_truthy((name == 'deftype')) else (name == 'defeffect')))))))))))): trampoline(eval_expr(expr, env)) return NIL else: @@ -3143,7 +3222,7 @@ async def async_map_render(exprs, env, ctx): return results # ASYNC_RENDER_FORMS -ASYNC_RENDER_FORMS = ['if', 'when', 'cond', 'case', 'let', 'let*', 'begin', 'do', 'define', 'defcomp', 'defisland', 'defmacro', 'defstyle', 'defhandler', 'map', 'map-indexed', 'filter', 'for-each'] +ASYNC_RENDER_FORMS = ['if', 'when', 'cond', 'case', 'let', 'let*', 'begin', 'do', 'define', 'defcomp', 'defisland', 'defmacro', 'defstyle', 'defhandler', 'deftype', 'defeffect', 'map', 'map-indexed', 'filter', 'for-each'] # async-render-form? def async_render_form_p(name): @@ -3518,7 +3597,7 @@ async def async_aser_call(name, args, env, ctx): return make_sx_expr(sx_str('(', join(' ', parts), ')')) # ASYNC_ASER_FORM_NAMES -ASYNC_ASER_FORM_NAMES = ['if', 'when', 'cond', 'case', 'and', 'or', 'let', 'let*', 'lambda', 'fn', 'define', 'defcomp', 'defmacro', 'defstyle', 'defhandler', 'defpage', 'defquery', 'defaction', 'begin', 'do', 'quote', '->', 'set!', 'defisland'] +ASYNC_ASER_FORM_NAMES = ['if', 'when', 'cond', 'case', 'and', 'or', 'let', 'let*', 'lambda', 'fn', 'define', 'defcomp', 'defmacro', 'defstyle', 'defhandler', 'defpage', 'defquery', 'defaction', 'begin', 'do', 'quote', '->', 'set!', 'defisland', 'deftype', 'defeffect'] # ASYNC_ASER_HO_NAMES ASYNC_ASER_HO_NAMES = ['map', 'map-indexed', 'filter', 'for-each'] @@ -3609,7 +3688,7 @@ async def dispatch_async_aser_form(name, expr, env, ctx): elif sx_truthy((name == 'defisland')): (await async_eval(expr, env, ctx)) return serialize(expr) - elif sx_truthy(((name == 'define') if sx_truthy((name == 'define')) else ((name == 'defcomp') if sx_truthy((name == 'defcomp')) else ((name == 'defmacro') if sx_truthy((name == 'defmacro')) else ((name == 'defstyle') if sx_truthy((name == 'defstyle')) else ((name == 'defhandler') if sx_truthy((name == 'defhandler')) else ((name == 'defpage') if sx_truthy((name == 'defpage')) else ((name == 'defquery') if sx_truthy((name == 'defquery')) else (name == 'defaction'))))))))): + elif sx_truthy(((name == 'define') if sx_truthy((name == 'define')) else ((name == 'defcomp') if sx_truthy((name == 'defcomp')) else ((name == 'defmacro') if sx_truthy((name == 'defmacro')) else ((name == 'defstyle') if sx_truthy((name == 'defstyle')) else ((name == 'defhandler') if sx_truthy((name == 'defhandler')) else ((name == 'defpage') if sx_truthy((name == 'defpage')) else ((name == 'defquery') if sx_truthy((name == 'defquery')) else ((name == 'defaction') if sx_truthy((name == 'defaction')) else ((name == 'deftype') if sx_truthy((name == 'deftype')) else (name == 'defeffect'))))))))))): (await async_eval(expr, env, ctx)) return NIL else: diff --git a/shared/sx/ref/test-types.sx b/shared/sx/ref/test-types.sx index 121ba23..688cb5d 100644 --- a/shared/sx/ref/test-types.sx +++ b/shared/sx/ref/test-types.sx @@ -427,6 +427,173 @@ (body (first (sx-parse "(div (+ name 1))"))) (type-env {"name" "string"}) (diagnostics (list))) - (check-body-walk body "~bad-math" type-env (test-prim-types) ppt (test-env) diagnostics) + (check-body-walk body "~bad-math" type-env (test-prim-types) ppt (test-env) diagnostics nil nil) (assert-true (> (len diagnostics) 0)) (assert-equal "error" (get (first diagnostics) "level"))))) + + +;; -------------------------------------------------------------------------- +;; deftype — type aliases +;; -------------------------------------------------------------------------- + +(defsuite "deftype-alias" + (deftest "simple alias resolves" + (let ((registry {"price" {:name "price" :params () :body "number"}})) + (assert-equal "number" (resolve-type "price" registry)))) + + (deftest "alias chain resolves" + (let ((registry {"price" {:name "price" :params () :body "number"} + "cost" {:name "cost" :params () :body "price"}})) + (assert-equal "number" (resolve-type "cost" registry)))) + + (deftest "unknown type passes through" + (let ((registry {"price" {:name "price" :params () :body "number"}})) + (assert-equal "string" (resolve-type "string" registry)))) + + (deftest "subtype-resolved? works through alias" + (let ((registry {"price" {:name "price" :params () :body "number"}})) + (assert-true (subtype-resolved? "price" "number" registry)) + (assert-true (subtype-resolved? "number" "price" registry))))) + + +;; -------------------------------------------------------------------------- +;; deftype — union types +;; -------------------------------------------------------------------------- + +(defsuite "deftype-union" + (deftest "union resolves" + (let ((registry {"status" {:name "status" :params () :body ("or" "string" "number")}})) + (let ((resolved (resolve-type "status" registry))) + (assert-true (= (type-of resolved) "list")) + (assert-equal "or" (first resolved))))) + + (deftest "subtype through named union" + (let ((registry {"status" {:name "status" :params () :body ("or" "string" "number")}})) + (assert-true (subtype-resolved? "string" "status" registry)) + (assert-true (subtype-resolved? "number" "status" registry)) + (assert-false (subtype-resolved? "boolean" "status" registry))))) + + +;; -------------------------------------------------------------------------- +;; deftype — record types +;; -------------------------------------------------------------------------- + +(defsuite "deftype-record" + (deftest "record resolves to dict" + (let ((registry {"card-props" {:name "card-props" :params () + :body {"title" "string" "price" "number"}}})) + (let ((resolved (resolve-type "card-props" registry))) + (assert-equal "dict" (type-of resolved)) + (assert-equal "string" (get resolved "title")) + (assert-equal "number" (get resolved "price"))))) + + (deftest "record structural subtyping" + (let ((registry {"card-props" {:name "card-props" :params () + :body {"title" "string" "price" "number"}} + "titled" {:name "titled" :params () + :body {"title" "string"}}})) + ;; card-props has title+price, titled has just title + ;; card-props <: titled (has all required fields) + (assert-true (subtype-resolved? "card-props" "titled" registry)))) + + (deftest "get infers field type from record" + (let ((registry {"card-props" {:name "card-props" :params () + :body {"title" "string" "price" "number"}}}) + (type-env {"d" "card-props"}) + (expr (first (sx-parse "(get d :title)")))) + (assert-equal "string" + (infer-type expr type-env (test-prim-types) registry))))) + + +;; -------------------------------------------------------------------------- +;; deftype — parameterized types +;; -------------------------------------------------------------------------- + +(defsuite "deftype-parameterized" + (deftest "maybe instantiation" + (let ((registry {"maybe" {:name "maybe" :params ("a") + :body ("or" "a" "nil")}})) + (let ((resolved (resolve-type (list "maybe" "string") registry))) + (assert-true (= (type-of resolved) "list")) + (assert-equal "or" (first resolved)) + (assert-true (contains? resolved "string")) + (assert-true (contains? resolved "nil"))))) + + (deftest "subtype through parameterized type" + (let ((registry {"maybe" {:name "maybe" :params ("a") + :body ("or" "a" "nil")}})) + (assert-true (subtype-resolved? "string" (list "maybe" "string") registry)) + (assert-true (subtype-resolved? "nil" (list "maybe" "string") registry)) + (assert-false (subtype-resolved? "number" (list "maybe" "string") registry)))) + + (deftest "substitute-type-vars works" + (let ((result (substitute-type-vars ("or" "a" "nil") (list "a") (list "number")))) + (assert-equal "or" (first result)) + (assert-true (contains? result "number")) + (assert-true (contains? result "nil"))))) + + +;; -------------------------------------------------------------------------- +;; defeffect — effect basics +;; -------------------------------------------------------------------------- + +(defsuite "defeffect-basics" + (deftest "get-effects returns nil for unannotated" + (let ((anns {"fetch" ("io")})) + (assert-true (nil? (get-effects "unknown" anns))))) + + (deftest "get-effects returns effects for annotated" + (let ((anns {"fetch" ("io")})) + (assert-equal (list "io") (get-effects "fetch" anns)))) + + (deftest "nil annotations returns nil" + (assert-true (nil? (get-effects "anything" nil))))) + + +;; -------------------------------------------------------------------------- +;; defeffect — effect checking +;; -------------------------------------------------------------------------- + +(defsuite "effect-checking" + (deftest "pure cannot call io" + (let ((anns {"~pure-comp" () "fetch" ("io")})) + (let ((diagnostics (check-effect-call "fetch" (list) anns "~pure-comp"))) + (assert-true (> (len diagnostics) 0)) + (assert-equal "error" (get (first diagnostics) "level"))))) + + (deftest "io context allows io" + (let ((anns {"~io-comp" ("io") "fetch" ("io")})) + (let ((diagnostics (check-effect-call "fetch" (list "io") anns "~io-comp"))) + (assert-equal 0 (len diagnostics))))) + + (deftest "unannotated caller allows everything" + (let ((anns {"fetch" ("io")})) + (let ((diagnostics (check-effect-call "fetch" nil anns "~unknown"))) + (assert-equal 0 (len diagnostics))))) + + (deftest "unannotated callee skips check" + (let ((anns {"~pure-comp" ()})) + (let ((diagnostics (check-effect-call "unknown-fn" (list) anns "~pure-comp"))) + (assert-equal 0 (len diagnostics)))))) + + +;; -------------------------------------------------------------------------- +;; defeffect — subset checking +;; -------------------------------------------------------------------------- + +(defsuite "effect-subset" + (deftest "empty is subset of anything" + (assert-true (effects-subset? (list) (list "io"))) + (assert-true (effects-subset? (list) (list)))) + + (deftest "io is subset of io" + (assert-true (effects-subset? (list "io") (list "io" "async")))) + + (deftest "io is not subset of pure" + (assert-false (effects-subset? (list "io") (list)))) + + (deftest "nil callee skips check" + (assert-true (effects-subset? nil (list)))) + + (deftest "nil caller allows all" + (assert-true (effects-subset? (list "io") nil)))) diff --git a/shared/sx/ref/types.sx b/shared/sx/ref/types.sx index 63e4370..e552757 100644 --- a/shared/sx/ref/types.sx +++ b/shared/sx/ref/types.sx @@ -224,7 +224,7 @@ ;; type-env is a dict mapping variable names → types. (define infer-type - (fn (node (type-env :as dict) (prim-types :as dict)) + (fn (node (type-env :as dict) (prim-types :as dict) type-registry) (let ((kind (type-of node))) (if (= kind "number") "number" (if (= kind "string") "string" @@ -234,24 +234,24 @@ (if (= kind "symbol") (let ((name (symbol-name node))) ;; Look up in type env - (if (dict-has? type-env name) - (dict-get type-env name) + (if (has-key? type-env name) + (get type-env name) ;; Builtins (if (= name "true") "boolean" (if (= name "false") "boolean" (if (= name "nil") "nil" ;; Check primitive return types - (if (dict-has? prim-types name) - (dict-get prim-types name) + (if (has-key? prim-types name) + (get prim-types name) "any")))))) (if (= kind "dict") "dict" (if (= kind "list") - (infer-list-type node type-env prim-types) + (infer-list-type node type-env prim-types type-registry) "any"))))))))))) (define infer-list-type - (fn (node (type-env :as dict) (prim-types :as dict)) + (fn (node (type-env :as dict) (prim-types :as dict) type-registry) ;; Infer type of a list expression (function call, special form, etc.) (if (empty? node) "list" (let ((head (first node)) @@ -261,32 +261,32 @@ (let ((name (symbol-name head))) ;; Special forms (if (= name "if") - (infer-if-type args type-env prim-types) + (infer-if-type args type-env prim-types type-registry) (if (= name "when") (if (>= (len args) 2) - (type-union (infer-type (last args) type-env prim-types) "nil") + (type-union (infer-type (last args) type-env prim-types type-registry) "nil") "nil") (if (or (= name "cond") (= name "case")) "any" ;; complex — could be refined later (if (= name "let") - (infer-let-type args type-env prim-types) + (infer-let-type args type-env prim-types type-registry) (if (or (= name "do") (= name "begin")) (if (empty? args) "nil" - (infer-type (last args) type-env prim-types)) + (infer-type (last args) type-env prim-types type-registry)) (if (or (= name "lambda") (= name "fn")) "lambda" (if (= name "and") (if (empty? args) "boolean" - (infer-type (last args) type-env prim-types)) + (infer-type (last args) type-env prim-types type-registry)) (if (= name "or") (if (empty? args) "boolean" ;; or returns first truthy — union of all args (reduce type-union "never" - (map (fn (a) (infer-type a type-env prim-types)) args))) + (map (fn (a) (infer-type a type-env prim-types type-registry)) args))) (if (= name "map") ;; map returns a list (if (>= (len args) 2) - (let ((fn-type (infer-type (first args) type-env prim-types))) + (let ((fn-type (infer-type (first args) type-env prim-types type-registry))) ;; If the fn's return type is known, produce (list-of return-type) (if (and (= (type-of fn-type) "list") (= (first fn-type) "->")) @@ -296,7 +296,7 @@ (if (= name "filter") ;; filter preserves element type (if (>= (len args) 2) - (infer-type (nth args 1) type-env prim-types) + (infer-type (nth args 1) type-env prim-types type-registry) "list") (if (= name "reduce") ;; reduce returns the accumulator type — too complex to infer @@ -311,26 +311,45 @@ "string" (if (= name "not") "boolean" + (if (= name "get") + ;; get — resolve record field type from type registry + (if (and (>= (len args) 2) (not (nil? type-registry))) + (let ((dict-type (infer-type (first args) type-env prim-types type-registry)) + (key-arg (nth args 1)) + (key-name (cond + (= (type-of key-arg) "keyword") (keyword-name key-arg) + (= (type-of key-arg) "string") key-arg + :else nil))) + (if (and key-name + (= (type-of dict-type) "string") + (has-key? type-registry dict-type)) + (let ((resolved (resolve-type dict-type type-registry))) + (if (and (= (type-of resolved) "dict") + (has-key? resolved key-name)) + (get resolved key-name) + "any")) + "any")) + "any") (if (starts-with? name "~") "element" ;; component call ;; Regular function call: look up return type - (if (dict-has? prim-types name) - (dict-get prim-types name) - "any")))))))))))))))))))))))) + (if (has-key? prim-types name) + (get prim-types name) + "any"))))))))))))))))))))))))) (define infer-if-type - (fn ((args :as list) (type-env :as dict) (prim-types :as dict)) + (fn ((args :as list) (type-env :as dict) (prim-types :as dict) type-registry) ;; (if test then else?) → union of then and else types (if (< (len args) 2) "nil" - (let ((then-type (infer-type (nth args 1) type-env prim-types))) + (let ((then-type (infer-type (nth args 1) type-env prim-types type-registry))) (if (>= (len args) 3) - (type-union then-type (infer-type (nth args 2) type-env prim-types)) + (type-union then-type (infer-type (nth args 2) type-env prim-types type-registry)) (type-union then-type "nil")))))) (define infer-let-type - (fn ((args :as list) (type-env :as dict) (prim-types :as dict)) + (fn ((args :as list) (type-env :as dict) (prim-types :as dict) type-registry) ;; (let ((x expr) ...) body) → type of body in extended type-env (if (< (len args) 2) "nil" (let ((bindings (first args)) @@ -343,10 +362,10 @@ (let ((name (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (str (first binding)))) - (val-type (infer-type (nth binding 1) extended prim-types))) + (val-type (infer-type (nth binding 1) extended prim-types type-registry))) (dict-set! extended name val-type)))) bindings) - (infer-type body extended prim-types))))) + (infer-type body extended prim-types type-registry))))) ;; -------------------------------------------------------------------------- @@ -371,14 +390,14 @@ ;; -------------------------------------------------------------------------- (define check-primitive-call - (fn ((name :as string) (args :as list) (type-env :as dict) (prim-types :as dict) prim-param-types (comp-name :as string)) + (fn ((name :as string) (args :as list) (type-env :as dict) (prim-types :as dict) prim-param-types (comp-name :as string) type-registry) ;; Check a primitive call site against declared param types. ;; prim-param-types is a dict: {prim-name → {:positional [...] :rest-type type-or-nil}} ;; Each positional entry is a list (name type-or-nil). ;; Returns list of diagnostics. (let ((diagnostics (list))) (when (and (not (nil? prim-param-types)) - (dict-has? prim-param-types name)) + (has-key? prim-param-types name)) (let ((sig (get prim-param-types name)) (positional (get sig "positional")) (rest-type (get sig "rest-type"))) @@ -392,10 +411,10 @@ (arg-expr (nth args idx))) (let ((expected-type (nth param-info 1))) (when (not (nil? expected-type)) - (let ((actual (infer-type arg-expr type-env prim-types))) + (let ((actual (infer-type arg-expr type-env prim-types type-registry))) (when (and (not (type-any? expected-type)) (not (type-any? actual)) - (not (subtype? actual expected-type))) + (not (subtype-resolved? actual expected-type type-registry))) (append! diagnostics (make-diagnostic "error" (str "Argument " (+ idx 1) " of `" name @@ -404,10 +423,10 @@ ;; Rest param — check against rest-type (when (not (nil? rest-type)) (let ((arg-expr (nth args idx)) - (actual (infer-type arg-expr type-env prim-types))) + (actual (infer-type arg-expr type-env prim-types type-registry))) (when (and (not (type-any? rest-type)) (not (type-any? actual)) - (not (subtype? actual rest-type))) + (not (subtype-resolved? actual rest-type type-registry))) (append! diagnostics (make-diagnostic "error" (str "Argument " (+ idx 1) " of `" name @@ -418,7 +437,7 @@ (define check-component-call - (fn ((comp-name :as string) (comp :as component) (call-args :as list) (type-env :as dict) (prim-types :as dict)) + (fn ((comp-name :as string) (comp :as component) (call-args :as list) (type-env :as dict) (prim-types :as dict) type-registry) ;; Check a component call site against its declared param types. ;; comp is the component value, call-args is the list of args ;; from the call site (after the component name). @@ -440,12 +459,12 @@ (when (< (+ idx 1) (len call-args)) (let ((val-expr (nth call-args (+ idx 1)))) ;; Check type of value against declared param type - (when (dict-has? param-types key-name) - (let ((expected (dict-get param-types key-name)) - (actual (infer-type val-expr type-env prim-types))) + (when (has-key? param-types key-name) + (let ((expected (get param-types key-name)) + (actual (infer-type val-expr type-env prim-types type-registry))) (when (and (not (type-any? expected)) (not (type-any? actual)) - (not (subtype? actual expected))) + (not (subtype-resolved? actual expected type-registry))) (append! diagnostics (make-diagnostic "error" (str "Keyword :" key-name " of " comp-name @@ -456,9 +475,9 @@ ;; Check for missing required params (those with declared types) (for-each (fn (param-name) - (when (and (dict-has? param-types param-name) + (when (and (has-key? param-types param-name) (not (contains? provided-keys param-name)) - (not (type-nullable? (dict-get param-types param-name)))) + (not (type-nullable? (get param-types param-name)))) (append! diagnostics (make-diagnostic "warning" (str "Required param :" param-name " of " comp-name " not provided") @@ -482,9 +501,11 @@ ;; -------------------------------------------------------------------------- (define check-body-walk - (fn (node (comp-name :as string) (type-env :as dict) (prim-types :as dict) prim-param-types env (diagnostics :as list)) + (fn (node (comp-name :as string) (type-env :as dict) (prim-types :as dict) prim-param-types env (diagnostics :as list) type-registry effect-annotations) ;; Recursively walk an AST and collect diagnostics. ;; prim-param-types: dict of {name → {:positional [...] :rest-type t}} or nil + ;; type-registry: dict of {type-name → type-def} or nil + ;; effect-annotations: dict of {fn-name → effect-list} or nil (let ((kind (type-of node))) (when (= kind "list") (when (not (empty? node)) @@ -500,16 +521,30 @@ (for-each (fn (d) (append! diagnostics d)) (check-component-call name comp-val args - type-env prim-types))))) + type-env prim-types type-registry)))) + ;; Effect check for component calls + (when (not (nil? effect-annotations)) + (let ((caller-effects (get-effects comp-name effect-annotations))) + (for-each + (fn (d) (append! diagnostics d)) + (check-effect-call name caller-effects effect-annotations comp-name))))) ;; Primitive call — check param types (when (and (not (starts-with? name "~")) (not (nil? prim-param-types)) - (dict-has? prim-param-types name)) + (has-key? prim-param-types name)) (for-each (fn (d) (append! diagnostics d)) (check-primitive-call name args type-env prim-types - prim-param-types comp-name))) + prim-param-types comp-name type-registry))) + + ;; Effect check for function calls + (when (and (not (starts-with? name "~")) + (not (nil? effect-annotations))) + (let ((caller-effects (get-effects comp-name effect-annotations))) + (for-each + (fn (d) (append! diagnostics d)) + (check-effect-call name caller-effects effect-annotations comp-name)))) ;; Recurse into let with extended type env (when (or (= name "let") (= name "let*")) @@ -524,12 +559,12 @@ (let ((bname (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (str (first binding)))) - (val-type (infer-type (nth binding 1) extended prim-types))) + (val-type (infer-type (nth binding 1) extended prim-types type-registry))) (dict-set! extended bname val-type)))) bindings) (for-each (fn (body) - (check-body-walk body comp-name extended prim-types prim-param-types env diagnostics)) + (check-body-walk body comp-name extended prim-types prim-param-types env diagnostics type-registry effect-annotations)) body-exprs)))) ;; Recurse into define with type binding @@ -541,13 +576,13 @@ (def-val (nth args 1))) (when def-name (dict-set! type-env def-name - (infer-type def-val type-env prim-types))) - (check-body-walk def-val comp-name type-env prim-types prim-param-types env diagnostics)))))) + (infer-type def-val type-env prim-types type-registry))) + (check-body-walk def-val comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations)))))) ;; Recurse into all child expressions (for-each (fn (child) - (check-body-walk child comp-name type-env prim-types prim-param-types env diagnostics)) + (check-body-walk child comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations)) args))))))) @@ -556,9 +591,11 @@ ;; -------------------------------------------------------------------------- (define check-component - (fn ((comp-name :as string) env (prim-types :as dict) prim-param-types) + (fn ((comp-name :as string) env (prim-types :as dict) prim-param-types type-registry effect-annotations) ;; Type-check a component's body. Returns list of diagnostics. ;; prim-param-types: dict of param type info, or nil to skip primitive checking. + ;; type-registry: dict of {type-name → type-def} or nil + ;; effect-annotations: dict of {fn-name → effect-list} or nil (let ((comp (env-get env comp-name)) (diagnostics (list))) (when (= (type-of comp) "component") @@ -572,15 +609,15 @@ (fn (p) (dict-set! type-env p (if (and (not (nil? param-types)) - (dict-has? param-types p)) - (dict-get param-types p) + (has-key? param-types p)) + (get param-types p) "any"))) params) ;; Add children as (list-of element) if component has children (when (component-has-children comp) (dict-set! type-env "children" (list "list-of" "element"))) - (check-body-walk body comp-name type-env prim-types prim-param-types env diagnostics))) + (check-body-walk body comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations))) diagnostics))) @@ -589,9 +626,11 @@ ;; -------------------------------------------------------------------------- (define check-all - (fn (env (prim-types :as dict) prim-param-types) + (fn (env (prim-types :as dict) prim-param-types type-registry effect-annotations) ;; Type-check every component in the environment. ;; prim-param-types: dict of param type info, or nil to skip primitive checking. + ;; type-registry: dict of {type-name → type-def} or nil + ;; effect-annotations: dict of {fn-name → effect-list} or nil ;; Returns list of all diagnostics. (let ((all-diagnostics (list))) (for-each @@ -600,7 +639,7 @@ (when (= (type-of val) "component") (for-each (fn (d) (append! all-diagnostics d)) - (check-component name env prim-types prim-param-types))))) + (check-component name env prim-types prim-param-types type-registry effect-annotations))))) (keys env)) all-diagnostics))) @@ -619,21 +658,208 @@ (let ((registry (dict))) (for-each (fn (decl) - (let ((name (dict-get decl "name")) - (returns (dict-get decl "returns"))) + (let ((name (get decl "name")) + (returns (get decl "returns"))) (when (and (not (nil? name)) (not (nil? returns))) (dict-set! registry name returns)))) prim-declarations) (for-each (fn (decl) - (let ((name (dict-get decl "name")) - (returns (dict-get decl "returns"))) + (let ((name (get decl "name")) + (returns (get decl "returns"))) (when (and (not (nil? name)) (not (nil? returns))) (dict-set! registry name returns)))) io-declarations) registry))) +;; -------------------------------------------------------------------------- +;; 13. User-defined types (deftype) +;; -------------------------------------------------------------------------- +;; Type definitions are plain dicts: {:name "price" :params [] :body "number"} +;; Stored in env under "*type-registry*" mapping type names to defs. + +;; make-type-def and normalize-type-body are defined in eval.sx +;; (always compiled). They're available when types.sx is compiled as a spec module. + +;; -- Standard type definitions -- +;; These define the record types used throughout the type system itself. + +;; Universal: nullable shorthand +(deftype (maybe a) (union a nil)) + +;; A type definition entry in the registry +(deftype type-def + {:name string :params list :body any}) + +;; A diagnostic produced by the type checker +(deftype diagnostic + {:level string :message string :component string? :expr any}) + +;; Primitive parameter type signature +(deftype prim-param-sig + {:positional list :rest-type string?}) + +;; Effect declarations +(defeffect io) +(defeffect mutation) +(defeffect render) + +(define type-def-name + (fn (td) (get td "name"))) + +(define type-def-params + (fn (td) (get td "params"))) + +(define type-def-body + (fn (td) (get td "body"))) + +(define resolve-type + (fn (t registry) + ;; Resolve a type through the registry. + ;; Returns the resolved type representation. + (if (nil? registry) t + (cond + ;; String — might be a named type alias + (= (type-of t) "string") + (if (has-key? registry t) + (let ((td (get registry t))) + (let ((params (type-def-params td)) + (body (type-def-body td))) + (if (empty? params) + ;; Simple alias — resolve the body recursively + (resolve-type body registry) + ;; Parameterized with no args — return as-is + t))) + t) + ;; List — might be parameterized type application or compound + (= (type-of t) "list") + (if (empty? t) t + (let ((head (first t))) + (cond + ;; (or ...), (list-of ...), (-> ...) — recurse into members + (or (= head "or") (= head "list-of") (= head "->") + (= head "dict-of")) + (cons head (map (fn (m) (resolve-type m registry)) (rest t))) + ;; Parameterized type application: ("maybe" "string") etc. + (and (= (type-of head) "string") + (has-key? registry head)) + (let ((td (get registry head)) + (params (type-def-params td)) + (body (type-def-body td)) + (args (rest t))) + (if (= (len params) (len args)) + (resolve-type + (substitute-type-vars body params args) + registry) + ;; Wrong arity — return as-is + t)) + :else t))) + ;; Dict — record type, resolve field types + (= (type-of t) "dict") + (map-dict (fn (k v) (resolve-type v registry)) t) + ;; Anything else — return as-is + :else t)))) + +(define substitute-type-vars + (fn (body (params :as list) (args :as list)) + ;; Substitute type variables in body. + ;; params is a list of type var names, args is corresponding types. + (let ((subst (dict))) + (for-each + (fn (i) + (dict-set! subst (nth params i) (nth args i))) + (range 0 (len params) 1)) + (substitute-in-type body subst)))) + +(define substitute-in-type + (fn (t (subst :as dict)) + ;; Recursively substitute type variables. + (cond + (= (type-of t) "string") + (if (has-key? subst t) (get subst t) t) + (= (type-of t) "list") + (map (fn (m) (substitute-in-type m subst)) t) + (= (type-of t) "dict") + (map-dict (fn (k v) (substitute-in-type v subst)) t) + :else t))) + +(define subtype-resolved? + (fn (a b registry) + ;; Resolve both sides through the registry, then check subtype. + (if (nil? registry) + (subtype? a b) + (let ((ra (resolve-type a registry)) + (rb (resolve-type b registry))) + ;; Handle record structural subtyping: dict a <: dict b + ;; if every field in b exists in a with compatible type + (if (and (= (type-of ra) "dict") (= (type-of rb) "dict")) + (every? + (fn (key) + (and (has-key? ra key) + (subtype-resolved? (get ra key) (get rb key) registry))) + (keys rb)) + (subtype? ra rb)))))) + + +;; -------------------------------------------------------------------------- +;; 14. Effect checking (defeffect) +;; -------------------------------------------------------------------------- +;; Effects are annotations on functions/components describing their +;; side effects. A pure function cannot call IO functions. + +(define get-effects + (fn ((name :as string) effect-annotations) + ;; Look up declared effects for a function/component. + ;; Returns list of effect strings, or nil if unannotated. + (if (nil? effect-annotations) nil + (if (has-key? effect-annotations name) + (get effect-annotations name) + nil)))) + +(define effects-subset? + (fn (callee-effects caller-effects) + ;; Are all callee effects allowed by caller? + ;; nil effects = unannotated = assumed to have all effects. + ;; Empty list = pure = no effects. + (if (nil? caller-effects) true ;; unannotated caller allows everything + (if (nil? callee-effects) true ;; unannotated callee — skip check + (every? + (fn (e) (contains? caller-effects e)) + callee-effects))))) + +(define check-effect-call + (fn ((callee-name :as string) caller-effects effect-annotations (comp-name :as string)) + ;; Check that callee's effects are allowed by caller's effects. + ;; Returns list of diagnostics. + (let ((diagnostics (list)) + (callee-effects (get-effects callee-name effect-annotations))) + (when (and (not (nil? caller-effects)) + (not (nil? callee-effects)) + (not (effects-subset? callee-effects caller-effects))) + (append! diagnostics + (make-diagnostic "error" + (str "`" callee-name "` has effects " + (join ", " callee-effects) + " but `" comp-name "` only allows " + (if (empty? caller-effects) "[pure]" + (join ", " caller-effects))) + comp-name nil))) + diagnostics))) + +(define build-effect-annotations + (fn ((io-declarations :as list)) + ;; Assign [io] effect to all IO primitives. + (let ((annotations (dict))) + (for-each + (fn (decl) + (let ((name (get decl "name"))) + (when (not (nil? name)) + (dict-set! annotations name (list "io"))))) + io-declarations) + annotations))) + + ;; -------------------------------------------------------------------------- ;; Platform interface summary ;; -------------------------------------------------------------------------- From a69604acaf718ffa3dafb5ca5519968b38212c70 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 11 Mar 2026 22:57:20 +0000 Subject: [PATCH 2/4] Add type annotations to remaining untyped spec params trampoline (eval.sx), signal/deref (signals.sx), aser (adapter-sx.sx). Co-Authored-By: Claude Opus 4.6 --- shared/static/scripts/sx-browser.js | 2 +- shared/sx/ref/adapter-sx.sx | 2 +- shared/sx/ref/eval.sx | 2 +- shared/sx/ref/signals.sx | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/shared/static/scripts/sx-browser.js b/shared/static/scripts/sx-browser.js index 73e7704..48da949 100644 --- a/shared/static/scripts/sx-browser.js +++ b/shared/static/scripts/sx-browser.js @@ -14,7 +14,7 @@ // ========================================================================= var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } }); - var SX_VERSION = "2026-03-11T22:28:29Z"; + var SX_VERSION = "2026-03-11T22:53:48Z"; function isNil(x) { return x === NIL || x === null || x === undefined; } function isSxTruthy(x) { return x !== false && !isNil(x); } diff --git a/shared/sx/ref/adapter-sx.sx b/shared/sx/ref/adapter-sx.sx index ddd4321..a97f5f6 100644 --- a/shared/sx/ref/adapter-sx.sx +++ b/shared/sx/ref/adapter-sx.sx @@ -21,7 +21,7 @@ (serialize result))))) (define aser - (fn (expr (env :as dict)) + (fn ((expr :as any) (env :as dict)) ;; Evaluate for SX wire format — serialize rendering forms, ;; evaluate control flow and function calls. (set-render-active! true) diff --git a/shared/sx/ref/eval.sx b/shared/sx/ref/eval.sx index 2c3717c..09467f6 100644 --- a/shared/sx/ref/eval.sx +++ b/shared/sx/ref/eval.sx @@ -55,7 +55,7 @@ ;; -------------------------------------------------------------------------- (define trampoline - (fn (val) + (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)) diff --git a/shared/sx/ref/signals.sx b/shared/sx/ref/signals.sx index 98ca89a..3491f7d 100644 --- a/shared/sx/ref/signals.sx +++ b/shared/sx/ref/signals.sx @@ -42,7 +42,7 @@ ;; -------------------------------------------------------------------------- (define signal - (fn (initial-value) + (fn ((initial-value :as any)) (make-signal initial-value))) @@ -55,7 +55,7 @@ ;; the current value — no subscription, no overhead. (define deref - (fn (s) + (fn ((s :as any)) (if (not (signal? s)) s ;; non-signal values pass through (let ((ctx (get-tracking-context))) From 0f9b4493159c97642d6c38fc8fa4b8dfef6e971a Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 11 Mar 2026 23:02:22 +0000 Subject: [PATCH 3/4] Add :effects annotations to boundary.sx IO and signal primitives All 11 define-io-primitive entries now declare :effects [io]. Signal primitives annotated: signal/deref/computed = [] (pure), reset!/swap!/effect/batch = [mutation]. Co-Authored-By: Claude Opus 4.6 --- shared/sx/ref/boundary.sx | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/shared/sx/ref/boundary.sx b/shared/sx/ref/boundary.sx index 32c2d08..5680b1c 100644 --- a/shared/sx/ref/boundary.sx +++ b/shared/sx/ref/boundary.sx @@ -12,6 +12,7 @@ ;; (define-io-primitive "name" ;; :params (param1 param2 &key ...) ;; :returns "type" +;; :effects [io] ;; :async true ;; :doc "description" ;; :context :request) @@ -38,6 +39,7 @@ (define-io-primitive "current-user" :params () :returns "dict?" + :effects [io] :async true :doc "Current authenticated user dict, or nil." :context :request) @@ -45,6 +47,7 @@ (define-io-primitive "request-arg" :params (name &rest default) :returns "any" + :effects [io] :async true :doc "Read a query string argument from the current request." :context :request) @@ -52,6 +55,7 @@ (define-io-primitive "request-path" :params () :returns "string" + :effects [io] :async true :doc "Current request path." :context :request) @@ -59,6 +63,7 @@ (define-io-primitive "request-view-args" :params (key) :returns "any" + :effects [io] :async true :doc "Read a URL view argument from the current request." :context :request) @@ -66,6 +71,7 @@ (define-io-primitive "csrf-token" :params () :returns "string" + :effects [io] :async true :doc "Current CSRF token string." :context :request) @@ -73,6 +79,7 @@ (define-io-primitive "abort" :params (status &rest message) :returns "nil" + :effects [io] :async true :doc "Raise HTTP error from SX." :context :request) @@ -82,6 +89,7 @@ (define-io-primitive "url-for" :params (endpoint &key) :returns "string" + :effects [io] :async true :doc "Generate URL for a named endpoint." :context :request) @@ -89,6 +97,7 @@ (define-io-primitive "route-prefix" :params () :returns "string" + :effects [io] :async true :doc "Service URL prefix for dev/prod routing." :context :request) @@ -98,6 +107,7 @@ (define-io-primitive "app-url" :params (service &rest path) :returns "string" + :effects [io] :async false :doc "Full URL for a service: (app-url \"blog\" \"/my-post/\")." :context :config) @@ -105,6 +115,7 @@ (define-io-primitive "asset-url" :params (&rest path) :returns "string" + :effects [io] :async false :doc "Versioned static asset URL." :context :config) @@ -112,6 +123,7 @@ (define-io-primitive "config" :params (key) :returns "any" + :effects [io] :async false :doc "Read a value from host configuration." :context :config) @@ -138,11 +150,13 @@ (declare-signal-primitive "signal" :params (initial-value) :returns "signal" + :effects [] :doc "Create a reactive signal container with an initial value.") (declare-signal-primitive "deref" :params (signal) :returns "any" + :effects [] :doc "Read a signal's current value. In a reactive context (inside an island), subscribes the current DOM binding to the signal. Outside reactive context, just returns the value.") @@ -150,23 +164,27 @@ (declare-signal-primitive "reset!" :params (signal value) :returns "nil" + :effects [mutation] :doc "Set a signal to a new value. Notifies all subscribers.") (declare-signal-primitive "swap!" :params (signal f &rest args) :returns "nil" + :effects [mutation] :doc "Update a signal by applying f to its current value. (swap! s inc) is equivalent to (reset! s (inc (deref s))) but atomic.") (declare-signal-primitive "computed" :params (compute-fn) :returns "signal" + :effects [] :doc "Create a derived signal that recomputes when its dependencies change. Dependencies are discovered automatically by tracking deref calls.") (declare-signal-primitive "effect" :params (effect-fn) :returns "lambda" + :effects [mutation] :doc "Run a side effect that re-runs when its signal dependencies change. Returns a dispose function. If the effect function returns a function, it is called as cleanup before the next run.") @@ -174,5 +192,6 @@ (declare-signal-primitive "batch" :params (thunk) :returns "any" + :effects [mutation] :doc "Group multiple signal writes. Subscribers are notified once at the end, after all values have been updated.") From 2f42e8826caff4030c23abafb4b730bb7d3bfe85 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 11 Mar 2026 23:22:34 +0000 Subject: [PATCH 4/4] Add :effects annotations to all spec files and update bootstrappers Bootstrappers (bootstrap_py.py, js.sx) now skip :effects keyword in define forms, enabling effect annotations throughout the spec without changing generated output. Annotated 180+ functions across 14 spec files: - signals.sx: signal/deref [] pure, reset!/swap!/effect/batch [mutation] - engine.sx: parse-* [] pure, morph-*/swap-* [mutation io] - orchestration.sx: all [mutation io] (browser event binding) - adapter-html.sx: render-* [render] - adapter-dom.sx: render-* [render], reactive-* [render mutation] - adapter-sx.sx: aser-* [render] - adapter-async.sx: async-render-*/async-aser-* [render io] - parser.sx: all [] pure - render.sx: predicates [] pure, process-bindings [mutation] - boot.sx: all [mutation io] (browser init) - deps.sx: scan-*/transitive-* [] pure, compute-all-* [mutation] - router.sx: all [] pure (URL matching) Co-Authored-By: Claude Opus 4.6 --- shared/static/scripts/sx-browser.js | 2 +- shared/sx/ref/adapter-async.sx | 82 +++++++++++----------- shared/sx/ref/adapter-dom.sx | 44 ++++++------ shared/sx/ref/adapter-html.sx | 24 +++---- shared/sx/ref/adapter-sx.sx | 18 ++--- shared/sx/ref/boot.sx | 28 ++++---- shared/sx/ref/bootstrap_py.py | 14 +++- shared/sx/ref/deps.sx | 38 +++++------ shared/sx/ref/engine.sx | 60 ++++++++-------- shared/sx/ref/js.sx | 7 +- shared/sx/ref/orchestration.sx | 102 ++++++++++++++-------------- shared/sx/ref/parser.sx | 42 ++++++------ shared/sx/ref/render.sx | 16 ++--- shared/sx/ref/router.sx | 12 ++-- shared/sx/ref/signals.sx | 42 ++++++------ shared/sx/ref/sx_ref.py | 2 +- 16 files changed, 274 insertions(+), 259 deletions(-) diff --git a/shared/static/scripts/sx-browser.js b/shared/static/scripts/sx-browser.js index 48da949..7b969d9 100644 --- a/shared/static/scripts/sx-browser.js +++ b/shared/static/scripts/sx-browser.js @@ -14,7 +14,7 @@ // ========================================================================= var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } }); - var SX_VERSION = "2026-03-11T22:53:48Z"; + var SX_VERSION = "2026-03-11T23:22:03Z"; function isNil(x) { return x === NIL || x === null || x === undefined; } function isSxTruthy(x) { return x !== false && !isNil(x); } diff --git a/shared/sx/ref/adapter-async.sx b/shared/sx/ref/adapter-async.sx index 09803f3..0922111 100644 --- a/shared/sx/ref/adapter-async.sx +++ b/shared/sx/ref/adapter-async.sx @@ -40,7 +40,7 @@ ;; Async HTML renderer ;; -------------------------------------------------------------------------- -(define-async async-render +(define-async async-render :effects [render io] (fn (expr (env :as dict) ctx) (case (type-of expr) "nil" "" @@ -56,7 +56,7 @@ :else (escape-html (str expr))))) -(define-async async-render-list +(define-async async-render-list :effects [render io] (fn (expr (env :as dict) ctx) (let ((head (first expr))) (if (not (= (type-of head) "symbol")) @@ -138,7 +138,7 @@ ;; async-render-raw — handle (raw! ...) in async context ;; -------------------------------------------------------------------------- -(define-async async-render-raw +(define-async async-render-raw :effects [render io] (fn ((args :as list) (env :as dict) ctx) (let ((parts (list))) (for-each @@ -157,7 +157,7 @@ ;; async-render-element — render an HTML element with async arg evaluation ;; -------------------------------------------------------------------------- -(define-async async-render-element +(define-async async-render-element :effects [render io] (fn ((tag :as string) (args :as list) (env :as dict) ctx) (let ((attrs (dict)) (children (list))) @@ -185,7 +185,7 @@ ;; Uses for-each + mutable state instead of reduce, because the bootstrapper ;; compiles inline for-each lambdas as for loops (which can contain await). -(define-async async-parse-element-args +(define-async async-parse-element-args :effects [render io] (fn ((args :as list) (attrs :as dict) (children :as list) (env :as dict) ctx) (let ((skip false) (i 0)) @@ -210,7 +210,7 @@ ;; async-render-component — expand and render a component asynchronously ;; -------------------------------------------------------------------------- -(define-async async-render-component +(define-async async-render-component :effects [render io] (fn ((comp :as component) (args :as list) (env :as dict) ctx) (let ((kwargs (dict)) (children (list))) @@ -232,7 +232,7 @@ ;; async-render-island — SSR render of reactive island with hydration markers ;; -------------------------------------------------------------------------- -(define-async async-render-island +(define-async async-render-island :effects [render io] (fn ((island :as island) (args :as list) (env :as dict) ctx) (let ((kwargs (dict)) (children (list))) @@ -261,7 +261,7 @@ ;; async-render-lambda — render lambda body in HTML context ;; -------------------------------------------------------------------------- -(define-async async-render-lambda +(define-async async-render-lambda :effects [render io] (fn ((f :as lambda) (args :as list) (env :as dict) ctx) (let ((local (env-merge (lambda-closure f) env))) (for-each-indexed @@ -274,7 +274,7 @@ ;; async-parse-kw-args — parse keyword args and children with async eval ;; -------------------------------------------------------------------------- -(define-async async-parse-kw-args +(define-async async-parse-kw-args :effects [render io] (fn ((args :as list) (kwargs :as dict) (children :as list) (env :as dict) ctx) (let ((skip false) (i 0)) @@ -300,7 +300,7 @@ ;; -------------------------------------------------------------------------- ;; Bootstrapper emits this as: [await async_render(x, env, ctx) for x in exprs] -(define-async async-map-render +(define-async async-map-render :effects [render io] (fn ((exprs :as list) (env :as dict) ctx) (let ((results (list))) (for-each @@ -319,7 +319,7 @@ "deftype" "defeffect" "map" "map-indexed" "filter" "for-each")) -(define async-render-form? +(define async-render-form? :effects [] (fn ((name :as string)) (contains? ASYNC_RENDER_FORMS name))) @@ -331,7 +331,7 @@ ;; Uses cond-scheme? from eval.sx (the FIXED version with every? check) ;; and eval-cond from render.sx for correct scheme/clojure classification. -(define-async dispatch-async-render-form +(define-async dispatch-async-render-form :effects [render io] (fn ((name :as string) expr (env :as dict) ctx) (cond ;; if @@ -407,7 +407,7 @@ ;; async-render-cond-scheme — scheme-style cond for render mode ;; -------------------------------------------------------------------------- -(define-async async-render-cond-scheme +(define-async async-render-cond-scheme :effects [render io] (fn ((clauses :as list) (env :as dict) ctx) (if (empty? clauses) "" @@ -429,7 +429,7 @@ ;; async-render-cond-clojure — clojure-style cond for render mode ;; -------------------------------------------------------------------------- -(define-async async-render-cond-clojure +(define-async async-render-cond-clojure :effects [render io] (fn ((clauses :as list) (env :as dict) ctx) (if (< (len clauses) 2) "" @@ -449,7 +449,7 @@ ;; async-process-bindings — evaluate let-bindings asynchronously ;; -------------------------------------------------------------------------- -(define-async async-process-bindings +(define-async async-process-bindings :effects [render io] (fn (bindings (env :as dict) ctx) ;; env-extend (not merge) — Env is not a dict subclass, so merge() ;; returns an empty dict, losing all parent scope bindings. @@ -470,7 +470,7 @@ local))) -(define-async async-process-bindings-flat +(define-async async-process-bindings-flat :effects [render io] (fn ((bindings :as list) (local :as dict) ctx) (let ((skip false) (i 0)) @@ -495,7 +495,7 @@ ;; async-map-fn-render — map a lambda/callable over collection for render ;; -------------------------------------------------------------------------- -(define-async async-map-fn-render +(define-async async-map-fn-render :effects [render io] (fn (f (coll :as list) (env :as dict) ctx) (let ((results (list))) (for-each @@ -512,7 +512,7 @@ ;; async-map-indexed-fn-render — map-indexed variant for render ;; -------------------------------------------------------------------------- -(define-async async-map-indexed-fn-render +(define-async async-map-indexed-fn-render :effects [render io] (fn (f (coll :as list) (env :as dict) ctx) (let ((results (list)) (i 0)) @@ -531,7 +531,7 @@ ;; async-invoke — call a native callable, await if coroutine ;; -------------------------------------------------------------------------- -(define-async async-invoke +(define-async async-invoke :effects [io] (fn (f &rest args) (let ((r (apply f args))) (if (async-coroutine? r) @@ -543,7 +543,7 @@ ;; Async SX wire format (aser) ;; ========================================================================== -(define-async async-aser +(define-async async-aser :effects [render io] (fn (expr (env :as dict) ctx) (case (type-of expr) "number" expr @@ -573,7 +573,7 @@ :else expr))) -(define-async async-aser-dict +(define-async async-aser-dict :effects [render io] (fn ((expr :as dict) (env :as dict) ctx) (let ((result (dict))) (for-each @@ -587,7 +587,7 @@ ;; async-aser-list — dispatch on list head for aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-list +(define-async async-aser-list :effects [render io] (fn (expr (env :as dict) ctx) (let ((head (first expr)) (args (rest expr))) @@ -666,7 +666,7 @@ ;; async-aser-eval-call — evaluate a function call fully in aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-eval-call +(define-async async-aser-eval-call :effects [render io] (fn (head (args :as list) (env :as dict) ctx) (let ((f (async-eval head env ctx)) (evaled-args (async-eval-args args env ctx))) @@ -694,7 +694,7 @@ ;; async-eval-args — evaluate a list of args asynchronously ;; -------------------------------------------------------------------------- -(define-async async-eval-args +(define-async async-eval-args :effects [io] (fn ((args :as list) (env :as dict) ctx) (let ((results (list))) (for-each @@ -707,7 +707,7 @@ ;; async-aser-map-list — aser each element of a list ;; -------------------------------------------------------------------------- -(define-async async-aser-map-list +(define-async async-aser-map-list :effects [render io] (fn ((exprs :as list) (env :as dict) ctx) (let ((results (list))) (for-each @@ -720,7 +720,7 @@ ;; async-aser-fragment — serialize (<> child1 child2 ...) in aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-fragment +(define-async async-aser-fragment :effects [render io] (fn ((children :as list) (env :as dict) ctx) (let ((parts (list))) (for-each @@ -744,7 +744,7 @@ ;; async-aser-component — expand component server-side in aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-component +(define-async async-aser-component :effects [render io] (fn ((comp :as component) (args :as list) (env :as dict) ctx) (let ((kwargs (dict)) (children (list))) @@ -776,7 +776,7 @@ ;; async-parse-aser-kw-args — parse keyword args for aser mode ;; -------------------------------------------------------------------------- -(define-async async-parse-aser-kw-args +(define-async async-parse-aser-kw-args :effects [render io] (fn ((args :as list) (kwargs :as dict) (children :as list) (env :as dict) ctx) (let ((skip false) (i 0)) @@ -801,7 +801,7 @@ ;; async-aser-call — serialize an SX call (tag or component) in aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-call +(define-async async-aser-call :effects [render io] (fn ((name :as string) (args :as list) (env :as dict) ctx) (let ((token (if (or (= name "svg") (= name "math")) (svg-context-set! true) @@ -860,7 +860,7 @@ (define ASYNC_ASER_HO_NAMES (list "map" "map-indexed" "filter" "for-each")) -(define async-aser-form? +(define async-aser-form? :effects [] (fn ((name :as string)) (or (contains? ASYNC_ASER_FORM_NAMES name) (contains? ASYNC_ASER_HO_NAMES name)))) @@ -872,7 +872,7 @@ ;; ;; Uses cond-scheme? from eval.sx (the FIXED version with every? check). -(define-async dispatch-async-aser-form +(define-async dispatch-async-aser-form :effects [render io] (fn ((name :as string) expr (env :as dict) ctx) (let ((args (rest expr))) (cond @@ -1002,7 +1002,7 @@ ;; async-aser-cond-scheme — scheme-style cond for aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-cond-scheme +(define-async async-aser-cond-scheme :effects [render io] (fn ((clauses :as list) (env :as dict) ctx) (if (empty? clauses) nil @@ -1024,7 +1024,7 @@ ;; async-aser-cond-clojure — clojure-style cond for aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-cond-clojure +(define-async async-aser-cond-clojure :effects [render io] (fn ((clauses :as list) (env :as dict) ctx) (if (< (len clauses) 2) nil @@ -1044,7 +1044,7 @@ ;; async-aser-case-loop — case dispatch for aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-case-loop +(define-async async-aser-case-loop :effects [render io] (fn (match-val (clauses :as list) (env :as dict) ctx) (if (< (len clauses) 2) nil @@ -1064,7 +1064,7 @@ ;; async-aser-thread-first — -> form in aser mode ;; -------------------------------------------------------------------------- -(define-async async-aser-thread-first +(define-async async-aser-thread-first :effects [render io] (fn ((args :as list) (env :as dict) ctx) (let ((result (async-eval (first args) env ctx))) (for-each @@ -1084,7 +1084,7 @@ ;; async-invoke-or-lambda — invoke a callable or lambda with args ;; -------------------------------------------------------------------------- -(define-async async-invoke-or-lambda +(define-async async-invoke-or-lambda :effects [render io] (fn (f (args :as list) (env :as dict) ctx) (cond (and (callable? f) (not (lambda? f)) (not (component? f))) @@ -1106,7 +1106,7 @@ ;; Async aser HO forms (map, map-indexed, for-each) ;; -------------------------------------------------------------------------- -(define-async async-aser-ho-map +(define-async async-aser-ho-map :effects [render io] (fn ((args :as list) (env :as dict) ctx) (let ((f (async-eval (first args) env ctx)) (coll (async-eval (nth args 1) env ctx)) @@ -1122,7 +1122,7 @@ results))) -(define-async async-aser-ho-map-indexed +(define-async async-aser-ho-map-indexed :effects [render io] (fn ((args :as list) (env :as dict) ctx) (let ((f (async-eval (first args) env ctx)) (coll (async-eval (nth args 1) env ctx)) @@ -1141,7 +1141,7 @@ results))) -(define-async async-aser-ho-for-each +(define-async async-aser-ho-for-each :effects [render io] (fn ((args :as list) (env :as dict) ctx) (let ((f (async-eval (first args) env ctx)) (coll (async-eval (nth args 1) env ctx)) @@ -1172,7 +1172,7 @@ ;; (sx-expr? x) — check if SxExpr ;; (set-expand-components!) — enable component expansion context var -(define-async async-eval-slot-inner +(define-async async-eval-slot-inner :effects [render io] (fn (expr (env :as dict) ctx) ;; NOTE: Uses statement-form let + set! to avoid expression-context ;; let (IIFE lambdas) which can't contain await in Python. @@ -1198,7 +1198,7 @@ (make-sx-expr (serialize result)))))))) -(define-async async-maybe-expand-result +(define-async async-maybe-expand-result :effects [render io] (fn (result (env :as dict) ctx) ;; If the aser result is a component call string like "(~foo ...)", ;; re-parse and expand it. This handles indirect component references diff --git a/shared/sx/ref/adapter-dom.sx b/shared/sx/ref/adapter-dom.sx index 5ff0b53..8c00e92 100644 --- a/shared/sx/ref/adapter-dom.sx +++ b/shared/sx/ref/adapter-dom.sx @@ -18,7 +18,7 @@ ;; render-to-dom — main entry point ;; -------------------------------------------------------------------------- -(define render-to-dom +(define render-to-dom :effects [render] (fn (expr (env :as dict) (ns :as string)) (set-render-active! true) (case (type-of expr) @@ -66,7 +66,7 @@ ;; render-dom-list — dispatch on list head ;; -------------------------------------------------------------------------- -(define render-dom-list +(define render-dom-list :effects [render] (fn (expr (env :as dict) (ns :as string)) (let ((head (first expr))) (cond @@ -165,7 +165,7 @@ ;; render-dom-element — create a DOM element with attrs and children ;; -------------------------------------------------------------------------- -(define render-dom-element +(define render-dom-element :effects [render] (fn ((tag :as string) (args :as list) (env :as dict) (ns :as string)) ;; Detect namespace from tag (let ((new-ns (cond (= tag "svg") SVG_NS @@ -236,7 +236,7 @@ ;; render-dom-component — expand and render a component ;; -------------------------------------------------------------------------- -(define render-dom-component +(define render-dom-component :effects [render] (fn ((comp :as component) (args :as list) (env :as dict) (ns :as string)) ;; Parse kwargs and children, bind into component env, render body. (let ((kwargs (dict)) @@ -283,7 +283,7 @@ ;; render-dom-fragment — render children into a DocumentFragment ;; -------------------------------------------------------------------------- -(define render-dom-fragment +(define render-dom-fragment :effects [render] (fn ((args :as list) (env :as dict) (ns :as string)) (let ((frag (create-fragment))) (for-each @@ -296,7 +296,7 @@ ;; render-dom-raw — insert unescaped content ;; -------------------------------------------------------------------------- -(define render-dom-raw +(define render-dom-raw :effects [render] (fn ((args :as list) (env :as dict)) (let ((frag (create-fragment))) (for-each @@ -317,7 +317,7 @@ ;; render-dom-unknown-component — visible warning element ;; -------------------------------------------------------------------------- -(define render-dom-unknown-component +(define render-dom-unknown-component :effects [render] (fn ((name :as string)) (error (str "Unknown component: " name)))) @@ -334,11 +334,11 @@ "map" "map-indexed" "filter" "for-each" "portal" "error-boundary")) -(define render-dom-form? +(define render-dom-form? :effects [] (fn ((name :as string)) (contains? RENDER_DOM_FORMS name))) -(define dispatch-render-form +(define dispatch-render-form :effects [render] (fn ((name :as string) expr (env :as dict) (ns :as string)) (cond ;; if — reactive inside islands (re-renders when signal deps change) @@ -580,7 +580,7 @@ ;; render-lambda-dom — render a lambda body in DOM context ;; -------------------------------------------------------------------------- -(define render-lambda-dom +(define render-lambda-dom :effects [render] (fn ((f :as lambda) (args :as list) (env :as dict) (ns :as string)) ;; Bind lambda params and render body as DOM (let ((local (env-merge (lambda-closure f) env))) @@ -604,7 +604,7 @@ ;; - Attribute bindings: (deref sig) in attr → reactive attribute ;; - Conditional fragments: (when (deref sig) ...) → reactive show/hide -(define render-dom-island +(define render-dom-island :effects [render mutation] (fn ((island :as island) (args :as list) (env :as dict) (ns :as string)) ;; Parse kwargs and children (same as component) (let ((kwargs (dict)) @@ -678,7 +678,7 @@ ;; ;; Supports :tag keyword to change wrapper element (default "div"). -(define render-dom-lake +(define render-dom-lake :effects [render] (fn ((args :as list) (env :as dict) (ns :as string)) (let ((lake-id nil) (lake-tag "div") @@ -722,7 +722,7 @@ ;; Renders as
children
. ;; Stores the island env and transform on the element for morph retrieval. -(define render-dom-marsh +(define render-dom-marsh :effects [render] (fn ((args :as list) (env :as dict) (ns :as string)) (let ((marsh-id nil) (marsh-tag "div") @@ -769,7 +769,7 @@ ;; reactive-text — create a text node bound to a signal ;; Used when (deref sig) appears in a text position inside an island. -(define reactive-text +(define reactive-text :effects [render mutation] (fn (sig) (let ((node (create-text-node (str (deref sig))))) (effect (fn () @@ -780,7 +780,7 @@ ;; Used when an attribute value contains (deref sig) inside an island. ;; Marks the attribute name on the element via data-sx-reactive-attrs so ;; the morph algorithm knows not to overwrite it with server content. -(define reactive-attr +(define reactive-attr :effects [render mutation] (fn (el (attr-name :as string) (compute-fn :as lambda)) ;; Mark this attribute as reactively managed (let ((existing (or (dom-get-attr el "data-sx-reactive-attrs") "")) @@ -801,7 +801,7 @@ ;; reactive-fragment — conditionally render a fragment based on a signal ;; Used for (when (deref sig) ...) or (if (deref sig) ...) inside an island. -(define reactive-fragment +(define reactive-fragment :effects [render mutation] (fn ((test-fn :as lambda) (render-fn :as lambda) (env :as dict) (ns :as string)) (let ((marker (create-comment "island-fragment")) (current-nodes (list))) @@ -823,13 +823,13 @@ ;; existing DOM nodes are reused across updates. Only additions, removals, ;; and reorderings touch the DOM. Without keys, falls back to clear+rerender. -(define render-list-item +(define render-list-item :effects [render] (fn ((map-fn :as lambda) item (env :as dict) (ns :as string)) (if (lambda? map-fn) (render-lambda-dom map-fn (list item) env ns) (render-to-dom (apply map-fn (list item)) env ns)))) -(define extract-key +(define extract-key :effects [render] (fn (node (index :as number)) ;; Extract key from rendered node: :key attr, data-key, or index fallback (let ((k (dom-get-attr node "key"))) @@ -838,7 +838,7 @@ (let ((dk (dom-get-data node "key"))) (if dk (str dk) (str "__idx_" index))))))) -(define reactive-list +(define reactive-list :effects [render mutation] (fn ((map-fn :as lambda) (items-sig :as signal) (env :as dict) (ns :as string)) (let ((container (create-fragment)) (marker (create-comment "island-list")) @@ -924,7 +924,7 @@ ;; ;; Handles: input[text/number/email/...], textarea, select, checkbox, radio -(define bind-input +(define bind-input :effects [render mutation] (fn (el (sig :as signal)) (let ((input-type (lower (or (dom-get-attr el "type") ""))) (is-checkbox (or (= input-type "checkbox") @@ -959,7 +959,7 @@ ;; position. Registers a disposer to clean up portal content on island ;; teardown. -(define render-dom-portal +(define render-dom-portal :effects [render] (fn ((args :as list) (env :as dict) (ns :as string)) (let ((selector (trampoline (eval-expr (first args) env))) (target (or (dom-query selector) @@ -999,7 +999,7 @@ ;; (fn (err retry) ...) ;; Calling (retry) re-renders the body, replacing the fallback. -(define render-dom-error-boundary +(define render-dom-error-boundary :effects [render] (fn ((args :as list) (env :as dict) (ns :as string)) (let ((fallback-expr (first args)) (body-exprs (rest args)) diff --git a/shared/sx/ref/adapter-html.sx b/shared/sx/ref/adapter-html.sx index fa44e2d..368dd89 100644 --- a/shared/sx/ref/adapter-html.sx +++ b/shared/sx/ref/adapter-html.sx @@ -13,7 +13,7 @@ ;; ========================================================================== -(define render-to-html +(define render-to-html :effects [render] (fn (expr (env :as dict)) (set-render-active! true) (case (type-of expr) @@ -33,7 +33,7 @@ ;; Everything else — evaluate first :else (render-value-to-html (trampoline (eval-expr expr env)) env)))) -(define render-value-to-html +(define render-value-to-html :effects [render] (fn (val (env :as dict)) (case (type-of val) "nil" "" @@ -55,7 +55,7 @@ "deftype" "defeffect" "map" "map-indexed" "filter" "for-each")) -(define render-html-form? +(define render-html-form? :effects [] (fn ((name :as string)) (contains? RENDER_HTML_FORMS name))) @@ -64,7 +64,7 @@ ;; render-list-to-html — dispatch on list head ;; -------------------------------------------------------------------------- -(define render-list-to-html +(define render-list-to-html :effects [render] (fn ((expr :as list) (env :as dict)) (if (empty? expr) "" @@ -135,7 +135,7 @@ ;; dispatch-html-form — render-aware special form handling for HTML output ;; -------------------------------------------------------------------------- -(define dispatch-html-form +(define dispatch-html-form :effects [render] (fn ((name :as string) (expr :as list) (env :as dict)) (cond ;; if @@ -235,7 +235,7 @@ ;; render-lambda-html — render a lambda body in HTML context ;; -------------------------------------------------------------------------- -(define render-lambda-html +(define render-lambda-html :effects [render] (fn ((f :as lambda) (args :as list) (env :as dict)) (let ((local (env-merge (lambda-closure f) env))) (for-each-indexed @@ -249,7 +249,7 @@ ;; render-html-component — expand and render a component ;; -------------------------------------------------------------------------- -(define render-html-component +(define render-html-component :effects [render] (fn ((comp :as component) (args :as list) (env :as dict)) ;; Expand component and render body through HTML adapter. ;; Component body contains rendering forms (HTML tags) that only the @@ -288,7 +288,7 @@ (render-to-html (component-body comp) local))))) -(define render-html-element +(define render-html-element :effects [render] (fn ((tag :as string) (args :as list) (env :as dict)) (let ((parsed (parse-element-args args env)) (attrs (first parsed)) @@ -312,7 +312,7 @@ ;; Lakes are server territory inside islands. The morph can update lake ;; content while preserving surrounding reactive DOM. -(define render-html-lake +(define render-html-lake :effects [render] (fn ((args :as list) (env :as dict)) (let ((lake-id nil) (lake-tag "div") @@ -351,7 +351,7 @@ ;; re-evaluated in the island's signal scope. Server renders children normally; ;; the :transform is a client-only concern. -(define render-html-marsh +(define render-html-marsh :effects [render] (fn ((args :as list) (env :as dict)) (let ((marsh-id nil) (marsh-tag "div") @@ -394,7 +394,7 @@ ;; (reset! s v) → no-op ;; (swap! s f) → no-op -(define render-html-island +(define render-html-island :effects [render] (fn ((island :as island) (args :as list) (env :as dict)) ;; Parse kwargs and children (same pattern as render-html-component) (let ((kwargs (dict)) @@ -452,7 +452,7 @@ ;; Uses the SX serializer (not JSON) so the client can parse with sx-parse. ;; Handles all SX types natively: numbers, strings, booleans, nil, lists, dicts. -(define serialize-island-state +(define serialize-island-state :effects [] (fn ((kwargs :as dict)) (if (empty-dict? kwargs) nil diff --git a/shared/sx/ref/adapter-sx.sx b/shared/sx/ref/adapter-sx.sx index a97f5f6..f55da20 100644 --- a/shared/sx/ref/adapter-sx.sx +++ b/shared/sx/ref/adapter-sx.sx @@ -11,7 +11,7 @@ ;; ========================================================================== -(define render-to-sx +(define render-to-sx :effects [render] (fn (expr (env :as dict)) (let ((result (aser expr env))) ;; aser-call already returns serialized SX strings; @@ -20,7 +20,7 @@ result (serialize result))))) -(define aser +(define aser :effects [render] (fn ((expr :as any) (env :as dict)) ;; Evaluate for SX wire format — serialize rendering forms, ;; evaluate control flow and function calls. @@ -51,7 +51,7 @@ :else expr))) -(define aser-list +(define aser-list :effects [render] (fn ((expr :as list) (env :as dict)) (let ((head (first expr)) (args (rest expr))) @@ -103,7 +103,7 @@ :else (error (str "Not callable: " (inspect f))))))))))) -(define aser-fragment +(define aser-fragment :effects [render] (fn ((children :as list) (env :as dict)) ;; Serialize (<> child1 child2 ...) to sx source string ;; Must flatten list results (e.g. from map/filter) to avoid nested parens @@ -125,7 +125,7 @@ (str "(<> " (join " " parts) ")"))))) -(define aser-call +(define aser-call :effects [render] (fn ((name :as string) (args :as list) (env :as dict)) ;; Serialize (name :key val child ...) — evaluate args but keep as sx ;; Uses for-each + mutable state (not reduce) so bootstrapper emits for-loops @@ -177,11 +177,11 @@ (list "map" "map-indexed" "filter" "reduce" "some" "every?" "for-each")) -(define special-form? +(define special-form? :effects [] (fn ((name :as string)) (contains? SPECIAL_FORM_NAMES name))) -(define ho-form? +(define ho-form? :effects [] (fn ((name :as string)) (contains? HO_FORM_NAMES name))) @@ -194,7 +194,7 @@ ;; through aser (serializing tags/components instead of rendering HTML). ;; Definition forms evaluate for side effects and return nil. -(define aser-special +(define aser-special :effects [render] (fn ((name :as string) (expr :as list) (env :as dict)) (let ((args (rest expr))) (cond @@ -315,7 +315,7 @@ ;; Helper: case dispatch for aser mode -(define eval-case-aser +(define eval-case-aser :effects [render] (fn (match-val (clauses :as list) (env :as dict)) (if (< (len clauses) 2) nil diff --git a/shared/sx/ref/boot.sx b/shared/sx/ref/boot.sx index 494bbf4..aca976a 100644 --- a/shared/sx/ref/boot.sx +++ b/shared/sx/ref/boot.sx @@ -26,7 +26,7 @@ (define HEAD_HOIST_SELECTOR "meta, title, link[rel='canonical'], script[type='application/ld+json']") -(define hoist-head-elements-full +(define hoist-head-elements-full :effects [mutation io] (fn (root) (let ((els (dom-query-all root HEAD_HOIST_SELECTOR))) (for-each @@ -71,7 +71,7 @@ ;; Mount — render SX source into a DOM element ;; -------------------------------------------------------------------------- -(define sx-mount +(define sx-mount :effects [mutation io] (fn (target (source :as string) (extra-env :as dict)) ;; Render SX source string into target element. ;; target: Element or CSS selector string @@ -100,7 +100,7 @@ ;; Finds the suspense wrapper by data-suspense attribute, renders the ;; new SX content, and replaces the wrapper's children. -(define resolve-suspense +(define resolve-suspense :effects [mutation io] (fn ((id :as string) (sx :as string)) ;; Process any new