giles
c0665ba58e
112 conversions across 19 .sx files using match, let-match, and pipe operators: match (17): type/value dispatch replacing cond/if chains - lib/vm.sx: HO form dispatch (for-each/map/filter/reduce/some/every?) - lib/tree-tools.sx: node-display, node-matches?, rename, count, replace, free-symbols - lib/types.sx: narrow-type, substitute-in-type, infer-type, resolve-type - web/engine.sx: default-trigger, resolve-target, classify-trigger - web/deps.sx: scan-refs-walk, scan-io-refs-walk let-match (89): dict destructuring replacing (get d "key") patterns - shared/page-functions.sx (20), blog/admin.sx (17), pub-api.sx (13) - events/ layouts/page/tickets/entries/forms (27 total) - specs-explorer.sx (7), federation/social.sx (3), lib/ small files (3) -> pipes (6): replacing triple-chained gets in lib/vm.sx - frame-closure → closure-code → code-bytecode chains Also: lib/vm.sx accessor upgrades (get vm "sp" → vm-sp vm throughout) 2650/2650 tests pass, zero regressions. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1279 lines
40 KiB
Plaintext
1279 lines
40 KiB
Plaintext
;; ==========================================================================
|
|
;; types.sx — Gradual type system for SX
|
|
;;
|
|
;; Registration-time type checking: zero runtime cost.
|
|
;; Annotations are optional — unannotated code defaults to `any`.
|
|
;;
|
|
;; This is an optional spec module — NOT part of the core evaluator.
|
|
;; It registers deftype and defeffect via register-special-form! at load time.
|
|
;;
|
|
;; Depends on: evaluator.sx (type-of, component accessors, env ops)
|
|
;; primitives.sx, boundary.sx (return type declarations)
|
|
;;
|
|
;; Platform interface (from evaluator.sx, already provided):
|
|
;; (type-of x) → type string
|
|
;; (symbol-name s) → string
|
|
;; (keyword-name k) → string
|
|
;; (component-body c) → AST
|
|
;; (component-params c) → list of param name strings
|
|
;; (component-has-children c) → boolean
|
|
;; (env-get env k) → value or nil
|
|
;;
|
|
;; New platform functions for types.sx:
|
|
;; (component-param-types c) → dict {param-name → type} or nil
|
|
;; (component-set-param-types! c d) → store param types on component
|
|
;; ==========================================================================
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; NOTE: deftype and defeffect definition forms have moved to web/web-forms.sx
|
|
;; (alongside defhandler, defpage, etc.) — they are domain forms, not core.
|
|
;; The type system below uses them but does not define them.
|
|
;; --------------------------------------------------------------------------
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 1. Type representation
|
|
;; --------------------------------------------------------------------------
|
|
;; Types are plain SX values:
|
|
;; - Strings for base types: "number", "string", "boolean", "nil",
|
|
;; "symbol", "keyword", "element", "any", "never"
|
|
;; - Nullable shorthand: "string?", "number?", "dict?", "boolean?"
|
|
;; → equivalent to (or string nil) etc.
|
|
;; - Lists for compound types:
|
|
;; (or t1 t2 ...) — union
|
|
;; (list-of t) — homogeneous list
|
|
;; (dict-of tk tv) — typed dict
|
|
;; (-> t1 t2 ... treturn) — function type (last is return)
|
|
|
|
;; Base type names
|
|
(define
|
|
base-types
|
|
(list
|
|
"number"
|
|
"string"
|
|
"boolean"
|
|
"nil"
|
|
"symbol"
|
|
"keyword"
|
|
"element"
|
|
"any"
|
|
"never"
|
|
"list"
|
|
"dict"
|
|
"lambda"
|
|
"component"
|
|
"island"
|
|
"macro"
|
|
"signal"))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 2. Type predicates
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define type-any? (fn (t) (= t "any")))
|
|
|
|
(define type-never? (fn (t) (= t "never")))
|
|
|
|
(define
|
|
type-nullable?
|
|
(fn
|
|
(t)
|
|
(if
|
|
(= t "any")
|
|
true
|
|
(if
|
|
(= t "nil")
|
|
true
|
|
(if
|
|
(and (= (type-of t) "string") (ends-with? t "?"))
|
|
true
|
|
(if
|
|
(and
|
|
(= (type-of t) "list")
|
|
(not (empty? t))
|
|
(= (first t) "or"))
|
|
(contains? (rest t) "nil")
|
|
false))))))
|
|
|
|
(define
|
|
nullable-base
|
|
(fn
|
|
(t)
|
|
(if
|
|
(and (= (type-of t) "string") (ends-with? t "?") (not (= t "?")))
|
|
(slice t 0 (- (string-length t) 1))
|
|
t)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 3. Subtype checking
|
|
;; --------------------------------------------------------------------------
|
|
;; subtype?(a, b) — is type `a` assignable to type `b`?
|
|
|
|
(define
|
|
subtype?
|
|
(fn
|
|
(a b)
|
|
(if
|
|
(type-any? b)
|
|
true
|
|
(if
|
|
(type-never? a)
|
|
true
|
|
(if
|
|
(type-any? a)
|
|
false
|
|
(if
|
|
(= a b)
|
|
true
|
|
(if
|
|
(= a "nil")
|
|
(type-nullable? b)
|
|
(if
|
|
(and (= (type-of b) "string") (ends-with? b "?"))
|
|
(let
|
|
((base (nullable-base b)))
|
|
(or (= a base) (= a "nil")))
|
|
(if
|
|
(and
|
|
(= (type-of a) "list")
|
|
(not (empty? a))
|
|
(= (first a) "or"))
|
|
(every? (fn (member) (subtype? member b)) (rest a))
|
|
(if
|
|
(and
|
|
(= (type-of b) "list")
|
|
(not (empty? b))
|
|
(= (first b) "or"))
|
|
(some (fn (member) (subtype? a member)) (rest b))
|
|
(if
|
|
(and
|
|
(= (type-of a) "list")
|
|
(= (type-of b) "list")
|
|
(= (len a) 2)
|
|
(= (len b) 2)
|
|
(= (first a) "list-of")
|
|
(= (first b) "list-of"))
|
|
(subtype? (nth a 1) (nth b 1))
|
|
(if
|
|
(and
|
|
(= a "list")
|
|
(= (type-of b) "list")
|
|
(= (len b) 2)
|
|
(= (first b) "list-of"))
|
|
(type-any? (nth b 1))
|
|
(if
|
|
(and
|
|
(= (type-of a) "list")
|
|
(= (len a) 2)
|
|
(= (first a) "list-of")
|
|
(= b "list"))
|
|
true
|
|
false)))))))))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 4. Type union
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define
|
|
type-union
|
|
(fn
|
|
(a b)
|
|
(if
|
|
(= a b)
|
|
a
|
|
(if
|
|
(type-any? a)
|
|
"any"
|
|
(if
|
|
(type-any? b)
|
|
"any"
|
|
(if
|
|
(type-never? a)
|
|
b
|
|
(if
|
|
(type-never? b)
|
|
a
|
|
(if
|
|
(subtype? a b)
|
|
b
|
|
(if
|
|
(subtype? b a)
|
|
a
|
|
(if
|
|
(= a "nil")
|
|
(if
|
|
(and
|
|
(= (type-of b) "string")
|
|
(not (ends-with? b "?")))
|
|
(str b "?")
|
|
(list "or" a b))
|
|
(if
|
|
(= b "nil")
|
|
(if
|
|
(and
|
|
(= (type-of a) "string")
|
|
(not (ends-with? a "?")))
|
|
(str a "?")
|
|
(list "or" a b))
|
|
(list "or" a b))))))))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 5. Type narrowing
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define
|
|
narrow-type
|
|
(fn
|
|
(t (predicate-name :as string))
|
|
(match
|
|
predicate-name
|
|
("nil?" (list "nil" (narrow-exclude-nil t)))
|
|
("string?" (list "string" (narrow-exclude t "string")))
|
|
("number?" (list "number" (narrow-exclude t "number")))
|
|
("list?" (list "list" (narrow-exclude t "list")))
|
|
("dict?" (list "dict" (narrow-exclude t "dict")))
|
|
("boolean?" (list "boolean" (narrow-exclude t "boolean")))
|
|
(_ (list t t)))))
|
|
|
|
|
|
(define
|
|
narrow-exclude-nil
|
|
(fn
|
|
(t)
|
|
(if
|
|
(= t "nil")
|
|
"never"
|
|
(if
|
|
(= t "any")
|
|
"any"
|
|
(if
|
|
(and (= (type-of t) "string") (ends-with? t "?"))
|
|
(nullable-base t)
|
|
(if
|
|
(and
|
|
(= (type-of t) "list")
|
|
(not (empty? t))
|
|
(= (first t) "or"))
|
|
(let
|
|
((members (filter (fn (m) (not (= m "nil"))) (rest t))))
|
|
(if
|
|
(= (len members) 1)
|
|
(first members)
|
|
(if (empty? members) "never" (cons "or" members))))
|
|
t))))))
|
|
|
|
|
|
(define
|
|
narrow-exclude
|
|
(fn
|
|
(t excluded)
|
|
(if
|
|
(= t excluded)
|
|
"never"
|
|
(if
|
|
(= t "any")
|
|
"any"
|
|
(if
|
|
(and
|
|
(= (type-of t) "list")
|
|
(not (empty? t))
|
|
(= (first t) "or"))
|
|
(let
|
|
((members (filter (fn (m) (not (= m excluded))) (rest t))))
|
|
(if
|
|
(= (len members) 1)
|
|
(first members)
|
|
(if (empty? members) "never" (cons "or" members))))
|
|
t)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 6. Type inference
|
|
;; --------------------------------------------------------------------------
|
|
;; infer-type walks an AST node and returns its inferred type.
|
|
;; type-env is a dict mapping variable names → types.
|
|
|
|
(define
|
|
infer-type
|
|
(fn
|
|
(node (type-env :as dict) (prim-types :as dict) type-registry)
|
|
(let
|
|
((kind (type-of node)))
|
|
(match
|
|
kind
|
|
("number" "number")
|
|
("string" "string")
|
|
("boolean" "boolean")
|
|
("keyword" "keyword")
|
|
("symbol"
|
|
(let
|
|
((name (symbol-name node)))
|
|
(if
|
|
(has-key? type-env name)
|
|
(get type-env name)
|
|
(if
|
|
(= name "true")
|
|
"boolean"
|
|
(if
|
|
(= name "false")
|
|
"boolean"
|
|
(if
|
|
(= name "nil")
|
|
"nil"
|
|
(if
|
|
(has-key? prim-types name)
|
|
(get prim-types name)
|
|
"any")))))))
|
|
("dict" "dict")
|
|
("list" (infer-list-type node type-env prim-types type-registry))
|
|
(_ (if (nil? node) "nil" "any"))))))
|
|
|
|
|
|
(define
|
|
infer-list-type
|
|
(fn
|
|
(node (type-env :as dict) (prim-types :as dict) type-registry)
|
|
(if
|
|
(empty? node)
|
|
"list"
|
|
(let
|
|
((head (first node)) (args (rest node)))
|
|
(if
|
|
(not (= (type-of head) "symbol"))
|
|
"any"
|
|
(let
|
|
((name (symbol-name head)))
|
|
(match
|
|
name
|
|
("if" (infer-if-type args type-env prim-types type-registry))
|
|
("when"
|
|
(if
|
|
(>= (len args) 2)
|
|
(type-union
|
|
(infer-type (last args) type-env prim-types type-registry)
|
|
"nil")
|
|
"nil"))
|
|
("cond" "any")
|
|
("case" "any")
|
|
("let" (infer-let-type args type-env prim-types type-registry))
|
|
("do"
|
|
(if
|
|
(empty? args)
|
|
"nil"
|
|
(infer-type (last args) type-env prim-types type-registry)))
|
|
("begin"
|
|
(if
|
|
(empty? args)
|
|
"nil"
|
|
(infer-type (last args) type-env prim-types type-registry)))
|
|
("lambda" "lambda")
|
|
("fn" "lambda")
|
|
("and"
|
|
(if
|
|
(empty? args)
|
|
"boolean"
|
|
(infer-type (last args) type-env prim-types type-registry)))
|
|
("or"
|
|
(if
|
|
(empty? args)
|
|
"boolean"
|
|
(reduce
|
|
type-union
|
|
"never"
|
|
(map
|
|
(fn
|
|
(a)
|
|
(infer-type a type-env prim-types type-registry))
|
|
args))))
|
|
("map"
|
|
(if
|
|
(>= (len args) 2)
|
|
(let
|
|
((fn-type (infer-type (first args) type-env prim-types type-registry)))
|
|
(if
|
|
(and
|
|
(= (type-of fn-type) "list")
|
|
(= (first fn-type) "->"))
|
|
(list "list-of" (last fn-type))
|
|
"list"))
|
|
"list"))
|
|
("filter"
|
|
(if
|
|
(>= (len args) 2)
|
|
(infer-type (nth args 1) type-env prim-types type-registry)
|
|
"list"))
|
|
("reduce" "any")
|
|
("list" "list")
|
|
("dict" "dict")
|
|
("quote" "any")
|
|
("str" "string")
|
|
("not" "boolean")
|
|
("get"
|
|
(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"
|
|
(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)
|
|
type-registry)
|
|
(if
|
|
(< (len args) 2)
|
|
"nil"
|
|
(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-registry))
|
|
(type-union then-type "nil"))))))
|
|
|
|
|
|
(define
|
|
infer-let-type
|
|
(fn
|
|
((args :as list)
|
|
(type-env :as dict)
|
|
(prim-types :as dict)
|
|
type-registry)
|
|
(if
|
|
(< (len args) 2)
|
|
"nil"
|
|
(let
|
|
((bindings (first args))
|
|
(body (last args))
|
|
(extended (merge type-env (dict))))
|
|
(for-each
|
|
(fn
|
|
(binding)
|
|
(when
|
|
(and (= (type-of binding) "list") (>= (len binding) 2))
|
|
(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
|
|
type-registry)))
|
|
(dict-set! extended name val-type))))
|
|
bindings)
|
|
(infer-type body extended prim-types type-registry)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 7. Diagnostic types
|
|
;; --------------------------------------------------------------------------
|
|
;; Diagnostics are dicts:
|
|
;; {:level "error"|"warning"|"info"
|
|
;; :message "human-readable explanation"
|
|
;; :component "~name" (or nil for top-level)
|
|
;; :expr <the offending AST node>}
|
|
|
|
(define
|
|
make-diagnostic
|
|
(fn ((level :as string) (message :as string) component expr) {:level level :component component :expr expr :message message}))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 8. Call-site checking
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)
|
|
type-registry)
|
|
(let
|
|
((diagnostics (list)))
|
|
(when
|
|
(and (not (nil? prim-param-types)) (has-key? prim-param-types name))
|
|
(let
|
|
((sig (get prim-param-types name))
|
|
(positional (get sig "positional"))
|
|
(rest-type (get sig "rest-type")))
|
|
(for-each
|
|
(fn
|
|
(idx)
|
|
(when
|
|
(< idx (len args))
|
|
(if
|
|
(< idx (len positional))
|
|
(let
|
|
((param-info (nth positional idx))
|
|
(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 type-registry)))
|
|
(when
|
|
(and
|
|
(not (type-any? expected-type))
|
|
(not (type-any? actual))
|
|
(not
|
|
(subtype-resolved?
|
|
actual
|
|
expected-type
|
|
type-registry)))
|
|
(append!
|
|
diagnostics
|
|
(make-diagnostic
|
|
"error"
|
|
(str
|
|
"Argument "
|
|
(+ idx 1)
|
|
" of `"
|
|
name
|
|
"` expects "
|
|
expected-type
|
|
", got "
|
|
actual)
|
|
comp-name
|
|
arg-expr)))))))
|
|
(when
|
|
(not (nil? rest-type))
|
|
(let
|
|
((arg-expr (nth args idx))
|
|
(actual
|
|
(infer-type
|
|
arg-expr
|
|
type-env
|
|
prim-types
|
|
type-registry)))
|
|
(when
|
|
(and
|
|
(not (type-any? rest-type))
|
|
(not (type-any? actual))
|
|
(not
|
|
(subtype-resolved? actual rest-type type-registry)))
|
|
(append!
|
|
diagnostics
|
|
(make-diagnostic
|
|
"error"
|
|
(str
|
|
"Argument "
|
|
(+ idx 1)
|
|
" of `"
|
|
name
|
|
"` expects "
|
|
rest-type
|
|
", got "
|
|
actual)
|
|
comp-name
|
|
arg-expr))))))))
|
|
(range 0 (len args) 1))))
|
|
diagnostics)))
|
|
|
|
|
|
(define
|
|
check-component-call
|
|
(fn
|
|
((comp-name :as string)
|
|
(comp :as component)
|
|
(call-args :as list)
|
|
(type-env :as dict)
|
|
(prim-types :as dict)
|
|
type-registry)
|
|
(let
|
|
((diagnostics (list))
|
|
(param-types (component-param-types comp))
|
|
(params (component-params comp)))
|
|
(when
|
|
(and (not (nil? param-types)) (not (empty? (keys param-types))))
|
|
(let
|
|
((i 0) (provided-keys (list)))
|
|
(for-each
|
|
(fn
|
|
(idx)
|
|
(when
|
|
(< idx (len call-args))
|
|
(let
|
|
((arg (nth call-args idx)))
|
|
(when
|
|
(= (type-of arg) "keyword")
|
|
(let
|
|
((key-name (keyword-name arg)))
|
|
(append! provided-keys key-name)
|
|
(when
|
|
(< (+ idx 1) (len call-args))
|
|
(let
|
|
((val-expr (nth call-args (+ idx 1))))
|
|
(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-resolved?
|
|
actual
|
|
expected
|
|
type-registry)))
|
|
(append!
|
|
diagnostics
|
|
(make-diagnostic
|
|
"error"
|
|
(str
|
|
"Keyword :"
|
|
key-name
|
|
" of "
|
|
comp-name
|
|
" expects "
|
|
expected
|
|
", got "
|
|
actual)
|
|
comp-name
|
|
val-expr))))))))))))
|
|
(range 0 (len call-args) 1))
|
|
(for-each
|
|
(fn
|
|
(param-name)
|
|
(when
|
|
(and
|
|
(has-key? param-types param-name)
|
|
(not (contains? provided-keys 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")
|
|
comp-name
|
|
nil))))
|
|
params)
|
|
(for-each
|
|
(fn
|
|
(key)
|
|
(when
|
|
(not (contains? params key))
|
|
(append!
|
|
diagnostics
|
|
(make-diagnostic
|
|
"warning"
|
|
(str "Unknown keyword :" key " passed to " comp-name)
|
|
comp-name
|
|
nil))))
|
|
provided-keys)))
|
|
diagnostics)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 9. AST walker — check a component body
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(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)
|
|
type-registry
|
|
effect-annotations)
|
|
(let
|
|
((kind (type-of node)))
|
|
(when
|
|
(= kind "list")
|
|
(when
|
|
(not (empty? node))
|
|
(let
|
|
((head (first node)) (args (rest node)))
|
|
(when
|
|
(= (type-of head) "symbol")
|
|
(let
|
|
((name (symbol-name head)))
|
|
(when
|
|
(starts-with? name "~")
|
|
(let
|
|
((comp-val (env-get env name)))
|
|
(when
|
|
(= (type-of comp-val) "component")
|
|
(for-each
|
|
(fn (d) (append! diagnostics d))
|
|
(check-component-call
|
|
name
|
|
comp-val
|
|
args
|
|
type-env
|
|
prim-types
|
|
type-registry))))
|
|
(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)))))
|
|
(when
|
|
(and
|
|
(not (starts-with? name "~"))
|
|
(not (nil? prim-param-types))
|
|
(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
|
|
type-registry)))
|
|
(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))))
|
|
(when
|
|
(or (= name "let") (= name "let*"))
|
|
(when
|
|
(>= (len args) 2)
|
|
(let
|
|
((bindings (first args))
|
|
(body-exprs (rest args))
|
|
(extended (merge type-env (dict))))
|
|
(for-each
|
|
(fn
|
|
(binding)
|
|
(when
|
|
(and
|
|
(= (type-of binding) "list")
|
|
(>= (len binding) 2))
|
|
(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
|
|
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
|
|
type-registry
|
|
effect-annotations))
|
|
body-exprs))))
|
|
(when
|
|
(= name "define")
|
|
(when
|
|
(>= (len args) 2)
|
|
(let
|
|
((def-name (if (= (type-of (first args)) "symbol") (symbol-name (first args)) nil))
|
|
(def-val (nth args 1)))
|
|
(when
|
|
def-name
|
|
(dict-set!
|
|
type-env
|
|
def-name
|
|
(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))))))
|
|
(for-each
|
|
(fn
|
|
(child)
|
|
(check-body-walk
|
|
child
|
|
comp-name
|
|
type-env
|
|
prim-types
|
|
prim-param-types
|
|
env
|
|
diagnostics
|
|
type-registry
|
|
effect-annotations))
|
|
args)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 10. Check a single component
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define
|
|
check-component
|
|
(fn
|
|
((comp-name :as string)
|
|
env
|
|
(prim-types :as dict)
|
|
prim-param-types
|
|
type-registry
|
|
effect-annotations)
|
|
(let
|
|
((comp (env-get env comp-name)) (diagnostics (list)))
|
|
(when
|
|
(= (type-of comp) "component")
|
|
(let
|
|
((body (component-body comp))
|
|
(params (component-params comp))
|
|
(param-types (component-param-types comp))
|
|
(type-env (dict)))
|
|
(for-each
|
|
(fn
|
|
(p)
|
|
(dict-set!
|
|
type-env
|
|
p
|
|
(if
|
|
(and (not (nil? param-types)) (has-key? param-types p))
|
|
(get param-types p)
|
|
"any")))
|
|
params)
|
|
(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
|
|
type-registry
|
|
effect-annotations)))
|
|
diagnostics)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 11. Check all components in an environment
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define
|
|
check-all
|
|
(fn
|
|
(env
|
|
(prim-types :as dict)
|
|
prim-param-types
|
|
type-registry
|
|
effect-annotations)
|
|
(let
|
|
((all-diagnostics (list)))
|
|
(for-each
|
|
(fn
|
|
(name)
|
|
(let
|
|
((val (env-get env name)))
|
|
(when
|
|
(= (type-of val) "component")
|
|
(for-each
|
|
(fn (d) (append! all-diagnostics d))
|
|
(check-component
|
|
name
|
|
env
|
|
prim-types
|
|
prim-param-types
|
|
type-registry
|
|
effect-annotations)))))
|
|
(keys env))
|
|
all-diagnostics)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 12. Build primitive type registry
|
|
;; --------------------------------------------------------------------------
|
|
;; Builds a dict mapping primitive-name → return-type from
|
|
;; the declarations parsed by boundary_parser.py.
|
|
;; This is called by the host at startup with the parsed declarations.
|
|
|
|
(define
|
|
build-type-registry
|
|
(fn
|
|
((prim-declarations :as list) (io-declarations :as list))
|
|
(let
|
|
((registry (dict)))
|
|
(for-each
|
|
(fn
|
|
(decl)
|
|
(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 (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 {:body any :params list :name string})
|
|
|
|
;; A diagnostic produced by the type checker
|
|
(deftype diagnostic {:level string :component string? :expr any :message string})
|
|
|
|
;; Primitive parameter type signature
|
|
(deftype prim-param-sig {:rest-type string? :positional list})
|
|
|
|
;; 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)
|
|
(if
|
|
(nil? registry)
|
|
t
|
|
(match
|
|
(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) (resolve-type body registry) t)))
|
|
t))
|
|
("list"
|
|
(if
|
|
(empty? t)
|
|
t
|
|
(let
|
|
((head (first t)))
|
|
(cond
|
|
(or
|
|
(= head "or")
|
|
(= head "list-of")
|
|
(= head "->")
|
|
(= head "dict-of"))
|
|
(cons
|
|
head
|
|
(map (fn (m) (resolve-type m registry)) (rest t)))
|
|
(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)
|
|
t))
|
|
:else t))))
|
|
("dict" (map-dict (fn (k v) (resolve-type v registry)) t))
|
|
(_ t)))))
|
|
|
|
(define
|
|
substitute-type-vars
|
|
(fn
|
|
(body (params :as list) (args :as list))
|
|
(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))
|
|
(match
|
|
(type-of t)
|
|
("string" (if (has-key? subst t) (get subst t) t))
|
|
("list" (map (fn (m) (substitute-in-type m subst)) t))
|
|
("dict" (map-dict (fn (k v) (substitute-in-type v subst)) t))
|
|
(_ t))))
|
|
|
|
(define
|
|
subtype-resolved?
|
|
(fn
|
|
(a b registry)
|
|
(if
|
|
(nil? registry)
|
|
(subtype? a b)
|
|
(let
|
|
((ra (resolve-type a registry)) (rb (resolve-type b registry)))
|
|
(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)
|
|
(if
|
|
(nil? effect-annotations)
|
|
nil
|
|
(if
|
|
(has-key? effect-annotations name)
|
|
(get effect-annotations name)
|
|
nil))))
|
|
|
|
(define
|
|
effects-subset?
|
|
(fn
|
|
(callee-effects caller-effects)
|
|
(if
|
|
(nil? caller-effects)
|
|
true
|
|
(if
|
|
(nil? callee-effects)
|
|
true
|
|
(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))
|
|
(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))
|
|
(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)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; 15. Check component effects — convenience wrapper
|
|
;; --------------------------------------------------------------------------
|
|
;; Validates that components respect their declared effect annotations.
|
|
;; Delegates to check-body-walk with nil type checking (effects only).
|
|
|
|
(define
|
|
check-component-effects
|
|
(fn
|
|
((comp-name :as string) env effect-annotations)
|
|
(let
|
|
((comp (env-get env comp-name)) (diagnostics (list)))
|
|
(when
|
|
(= (type-of comp) "component")
|
|
(let
|
|
((body (component-body comp)))
|
|
(check-body-walk
|
|
body
|
|
comp-name
|
|
(dict)
|
|
(dict)
|
|
nil
|
|
env
|
|
diagnostics
|
|
nil
|
|
effect-annotations)))
|
|
diagnostics)))
|
|
|
|
(define
|
|
check-all-effects
|
|
(fn
|
|
(env effect-annotations)
|
|
(let
|
|
((all-diagnostics (list)))
|
|
(for-each
|
|
(fn
|
|
(name)
|
|
(let
|
|
((val (env-get env name)))
|
|
(when
|
|
(= (type-of val) "component")
|
|
(for-each
|
|
(fn (d) (append! all-diagnostics d))
|
|
(check-component-effects name env effect-annotations)))))
|
|
(keys env))
|
|
all-diagnostics)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Platform interface summary
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; From eval.sx (already provided):
|
|
;; (type-of x), (symbol-name s), (keyword-name k), (env-get env k)
|
|
;; (component-body c), (component-params c), (component-has-children c)
|
|
;;
|
|
;; New for types.sx (each host implements):
|
|
;; (component-param-types c) → dict {param-name → type} or nil
|
|
;; (component-set-param-types! c d) → store param types on component
|
|
;; (merge d1 d2) → new dict merging d1 and d2
|
|
;;
|
|
;; Primitive param types:
|
|
;; The host provides prim-param-types as a dict mapping primitive names
|
|
;; to param type descriptors. Each descriptor is a dict:
|
|
;; {"positional" [["name" "type-or-nil"] ...] "rest-type" "type-or-nil"}
|
|
;; Built by boundary_parser.parse_primitive_param_types() in Python.
|
|
;; Passed to check-component/check-all as an optional extra argument.
|
|
;;
|
|
;; --------------------------------------------------------------------------
|