coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add deftype and defeffect to SX type system (Phases 6-7)

Browse Source 
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 <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-11 22:51:19 +00:00
parent b8018ba385
commit ce7ad125b6
12 changed files with 938 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files

75
shared/static/scripts/sx-browser.js
View File

@@ -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

7
shared/sx/ref/adapter-async.sx
View File

@@ -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

1
shared/sx/ref/adapter-html.sx
View File

@@ -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?

6
shared/sx/ref/adapter-sx.sx
View File

@@ -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

116
shared/sx/ref/eval.sx
View File

@@ -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)

5
shared/sx/ref/platform_py.py
View File

@@ -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)

3
shared/sx/ref/render.sx
View File

@@ -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

180
shared/sx/ref/run_type_tests.py Normal file
View File

@@ -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)

23
shared/sx/ref/special-forms.sx
View File

@@ -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

95
shared/sx/ref/sx_ref.py
View File

@@ -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:

169
shared/sx/ref/test-types.sx
View File

@@ -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))))

338
shared/sx/ref/types.sx
View File

@@ -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
;; --------------------------------------------------------------------------