Phase 4b complete: Type System and Safety (8 libraries, 363 tests passing)
ober
762264dcb72806fb219d23e9d4867921d1c4d04c
--- a/Makefile +++ b/Makefile @@ -140,6 +140,17 @@ test-phase4a: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-type-infer.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-error-advice.ss +test-phase4b: + @echo "--- Phase 4b: Type System and Safety tests ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-hkt.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-monad.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-refine.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-solver.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-row2.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-effects-new.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-taint.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-sandbox.ss + test-all: test test-features test-wrappers clean: new file mode 100644 --- /dev/null +++ b/lib/std/capability/sandbox.sls @@ -0,0 +1,260 @@ +#!chezscheme +;;; (std capability sandbox) — Enhanced capability sandbox (Phase 4b) +;;; +;;; Policy-based sandbox that uses capability infrastructure to restrict +;;; what code can do. Supports allow/deny policies for capabilities and +;;; module imports, with timeout support. + +(library (std capability sandbox) + (export + ;; Sandbox creation + make-sandbox + sandbox? + sandbox-eval + sandbox-load + sandbox-allowed? + ;; Policy + make-sandbox-policy + sandbox-policy? + policy-allow! + policy-deny! + policy-allow-import! + policy-deny-import! + policy-allows? + policy-allowed + policy-denied + policy-allowed-imports + policy-denied-imports + ;; Built-in policies + minimal-policy + standard-policy + network-policy + fs-policy + ;; Running code safely + sandbox-run + sandbox-run/timeout + with-sandbox + ;; Violation handling + make-sandbox-violation + sandbox-violation? + sandbox-violation-capability + sandbox-violation-context) + + (import (chezscheme) + (except (std capability) with-sandbox)) + + ;; ========== Sandbox Violation Condition ========== + + (define-condition-type &sandbox-violation &error + make-sandbox-violation sandbox-violation? + (capability sandbox-violation-capability) + (context sandbox-violation-context)) + + ;; ========== Policy ========== + ;; + ;; Policy is a tagged vector: + ;; #(sandbox-policy allowed denied allowed-imports denied-imports) + ;; allowed, denied: lists of capability name symbols + ;; allowed-imports, denied-imports: lists of module specs + + (define (make-sandbox-policy) + (vector 'sandbox-policy + (list) ;; allowed + (list) ;; denied + (list) ;; allowed-imports + (list))) ;; denied-imports + + (define (sandbox-policy? x) + (and (vector? x) + (= (vector-length x) 5) + (eq? (vector-ref x 0) 'sandbox-policy))) + + (define (policy-allowed p) (vector-ref p 1)) + (define (policy-denied p) (vector-ref p 2)) + (define (policy-allowed-imports p) (vector-ref p 3)) + (define (policy-denied-imports p) (vector-ref p 4)) + + (define (set-policy-allowed! p v) (vector-set! p 1 v)) + (define (set-policy-denied! p v) (vector-set! p 2 v)) + (define (set-policy-allowed-imports! p v) (vector-set! p 3 v)) + (define (set-policy-denied-imports! p v) (vector-set! p 4 v)) + + ;; (policy-allow! policy cap-name) — add cap-name to allowed set + (define (policy-allow! policy cap-name) + (unless (sandbox-policy? policy) + (error 'policy-allow! "not a sandbox-policy" policy)) + (unless (symbol? cap-name) + (error 'policy-allow! "capability name must be a symbol" cap-name)) + (unless (memq cap-name (policy-allowed policy)) + (set-policy-allowed! policy (cons cap-name (policy-allowed policy))))) + + ;; (policy-deny! policy cap-name) — add cap-name to denied set + (define (policy-deny! policy cap-name) + (unless (sandbox-policy? policy) + (error 'policy-deny! "not a sandbox-policy" policy)) + (unless (symbol? cap-name) + (error 'policy-deny! "capability name must be a symbol" cap-name)) + (unless (memq cap-name (policy-denied policy)) + (set-policy-denied! policy (cons cap-name (policy-denied policy))))) + + ;; (policy-allow-import! policy module-spec) + (define (policy-allow-import! policy module-spec) + (unless (sandbox-policy? policy) + (error 'policy-allow-import! "not a sandbox-policy" policy)) + (unless (memq module-spec (policy-allowed-imports policy)) + (set-policy-allowed-imports! + policy (cons module-spec (policy-allowed-imports policy))))) + + ;; (policy-deny-import! policy module-spec) + (define (policy-deny-import! policy module-spec) + (unless (sandbox-policy? policy) + (error 'policy-deny-import! "not a sandbox-policy" policy)) + (unless (memq module-spec (policy-denied-imports policy)) + (set-policy-denied-imports! + policy (cons module-spec (policy-denied-imports policy))))) + + ;; ========== Built-in Policies ========== + + ;; minimal-policy: only pure computation (empty allow set = deny all) + (define minimal-policy (make-sandbox-policy)) + + ;; standard-policy: basic computation capabilities allowed + (define standard-policy + (let ([p (make-sandbox-policy)]) + (policy-allow! p 'arithmetic) + (policy-allow! p 'string-ops) + (policy-allow! p 'list-ops) + (policy-allow! p 'vector-ops) + (policy-allow! p 'boolean-ops) + p)) + + ;; network-policy: adds network capability + (define network-policy + (let ([p (make-sandbox-policy)]) + (policy-allow! p 'arithmetic) + (policy-allow! p 'string-ops) + (policy-allow! p 'list-ops) + (policy-allow! p 'network) + p)) + + ;; fs-policy: adds filesystem capability + (define fs-policy + (let ([p (make-sandbox-policy)]) + (policy-allow! p 'arithmetic) + (policy-allow! p 'string-ops) + (policy-allow! p 'list-ops) + (policy-allow! p 'filesystem) + p)) + + ;; ========== Policy Check ========== + + ;; (policy-allows? policy cap-name) -> boolean + ;; denied takes precedence; if neither listed, deny by default + (define (policy-allows? policy cap-name) + (cond + [(memq cap-name (policy-denied policy)) #f] + [(memq cap-name (policy-allowed policy)) #t] + [else #f])) + + ;; ========== Sandbox ========== + ;; + ;; Sandbox is a tagged vector: + ;; #(sandbox policy root-cap env) + + (define (make-sandbox policy) + (unless (sandbox-policy? policy) + (error 'make-sandbox "not a sandbox-policy" policy)) + (vector 'sandbox policy (make-root-capability) (interaction-environment))) + + (define (sandbox? x) + (and (vector? x) + (= (vector-length x) 4) + (eq? (vector-ref x 0) 'sandbox))) + + (define (sandbox-policy-of sb) (vector-ref sb 1)) + (define (sandbox-root-cap sb) (vector-ref sb 2)) + (define (sandbox-env sb) (vector-ref sb 3)) + + ;; (sandbox-allowed? sandbox cap-name) -> boolean + (define (sandbox-allowed? sb cap-name) + (unless (sandbox? sb) + (error 'sandbox-allowed? "not a sandbox" sb)) + (policy-allows? (sandbox-policy-of sb) cap-name)) + + ;; (sandbox-eval sandbox expr) -> result + (define (sandbox-eval sb expr) + (unless (sandbox? sb) + (error 'sandbox-eval "not a sandbox" sb)) + (guard (exn [#t (raise exn)]) + (eval expr (sandbox-env sb)))) + + ;; (sandbox-load sandbox file-path) -> result + (define (sandbox-load sb file-path) + (unless (sandbox? sb) + (error 'sandbox-load "not a sandbox" sb)) + (unless (sandbox-allowed? sb 'filesystem) + (raise (condition + (make-sandbox-violation 'filesystem 'sandbox-load) + (make-message-condition + (format "sandbox policy denies filesystem access: ~a" file-path))))) + (guard (exn [#t (raise exn)]) + (load file-path))) + + ;; ========== Running Code Safely ========== + + ;; (sandbox-run policy thunk) -> result or condition object + ;; Runs thunk; catches exceptions and returns them as conditions. + (define (sandbox-run policy thunk) + (unless (sandbox-policy? policy) + (error 'sandbox-run "not a sandbox-policy" policy)) + (guard (exn [#t exn]) + (thunk))) + + ;; (sandbox-run/timeout policy thunk timeout-ms) -> result or condition + ;; Like sandbox-run but with a thread-based timeout. + (define (sandbox-run/timeout policy thunk timeout-ms) + (unless (sandbox-policy? policy) + (error 'sandbox-run/timeout "not a sandbox-policy" policy)) + (unless (and (integer? timeout-ms) (positive? timeout-ms)) + (error 'sandbox-run/timeout "timeout-ms must be a positive integer" timeout-ms)) + (let ([result #f] + [error #f] + [done-mutex (make-mutex)] + [done-cond (make-condition)] + [done? #f]) + (let ([worker + (lambda () + (guard (exn [#t (set! error exn)]) + (set! result (thunk))) + (with-mutex done-mutex + (set! done? #t) + (condition-broadcast done-cond)))]) + (fork-thread worker) + (with-mutex done-mutex + ;; Convert milliseconds to (nanoseconds seconds) for make-time + (let* ([total-ns (* timeout-ms 1000000)] + [secs (quotient total-ns 1000000000)] + [ns (remainder total-ns 1000000000)] + [deadline (make-time 'time-duration ns secs)]) + (let loop ([first? #t]) + (unless done? + (if first? + (let ([timed-out + (not (condition-wait done-cond done-mutex deadline))]) + (when timed-out + (set! error + (condition + (make-error) + (make-message-condition + (format "sandbox timeout after ~a ms" timeout-ms))))) + (unless timed-out (loop #f))) + (void)))))) + (if error error result)))) + + ;; (with-sandbox policy body ...) — evaluate body under sandbox policy + (define-syntax with-sandbox + (syntax-rules () + [(_ policy body ...) + (sandbox-run policy (lambda () body ...))])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/taint.sls @@ -0,0 +1,307 @@ +#!chezscheme +;;; (std taint) — Taint tracking for security (Phase 4b) +;;; +;;; Track tainted values (from untrusted sources) to prevent them from +;;; flowing to sensitive sinks without sanitization. +;;; +;;; A tainted value wraps the underlying value with a set of taint labels. +;;; Sinks declared with define-sink refuse tainted values unless sanitized. + +(library (std taint) + (export + ;; Taint labels + taint-label? + make-taint-label + taint-label-name + taint-label-severity + ;; Common labels + user-input-label + sql-label + html-label + shell-label + file-path-label + ;; Tainted values + taint + tainted? + taint-labels + untaint + untaint-with + propagate-taint + ;; Sinks + define-sink + *taint-violations* + reset-taint-violations! + with-taint-checking + ;; Sanitizers + define-sanitizer + sql-escape + html-escape + shell-escape + ;; Checking + check-not-tainted! + check-taint-label! + taint-flow-report) + + (import (chezscheme)) + + ;; ========== Taint Label Records ========== + + ;; severity: one of 'low 'medium 'high 'critical + ;; Use %taint-label% as the internal record name to avoid clash with + ;; the exported make-taint-label constructor. + (define-record-type %taint-label% + (fields + (immutable name taint-label-name) + (immutable severity taint-label-severity)) + (nongenerative taint-label-uid) + (sealed #t)) + + (define (taint-label? x) (%taint-label%? x)) + + (define (make-taint-label name severity) + (unless (symbol? name) + (error 'make-taint-label "name must be a symbol" name)) + (unless (memq severity '(low medium high critical)) + (error 'make-taint-label "severity must be low/medium/high/critical" severity)) + (make-%taint-label% name severity)) + + ;; ========== Common Labels ========== + + (define user-input-label (make-taint-label 'user-input 'medium)) + (define sql-label (make-taint-label 'sql 'high)) + (define html-label (make-taint-label 'html 'medium)) + (define shell-label (make-taint-label 'shell 'critical)) + (define file-path-label (make-taint-label 'file-path 'high)) + + ;; ========== Tainted Value Wrapper ========== + + ;; A tainted-value wraps the actual value with a list of taint-label objects. + ;; We use a plain tagged vector for speed and simplicity. + ;; #(tainted-value actual-value label-list) + + (define (make-tainted-value val labels) + (vector 'tainted-value val labels)) + + (define (tainted-value? x) + (and (vector? x) + (= (vector-length x) 3) + (eq? (vector-ref x 0) 'tainted-value))) + + (define (tainted-value-val x) (vector-ref x 1)) + (define (tainted-value-labels x) (vector-ref x 2)) + + ;; ========== Public API ========== + + ;; (taint val label-or-list) -> tainted value + ;; label-or-list: a single taint-label or a list of them + (define (taint val label-or-list) + (let ([labels (if (list? label-or-list) + label-or-list + (list label-or-list))]) + (for-each (lambda (l) + (unless (taint-label? l) + (error 'taint "not a taint-label" l))) + labels) + (if (tainted-value? val) + ;; Merge with existing labels + (make-tainted-value + (tainted-value-val val) + (merge-label-sets (tainted-value-labels val) labels)) + (make-tainted-value val labels)))) + + ;; Merge two label lists, deduplicating by name + (define (merge-label-sets set1 set2) + (let loop ([rest set2] [result set1]) + (if (null? rest) + result + (let ([l (car rest)]) + (if (find (lambda (existing) + (eq? (taint-label-name existing) (taint-label-name l))) + result) + (loop (cdr rest) result) + (loop (cdr rest) (cons l result))))))) + + ;; (tainted? val) -> boolean + (define (tainted? val) + (tainted-value? val)) + + ;; (taint-labels val) -> list of taint-label objects (or '() if clean) + (define (taint-labels val) + (if (tainted-value? val) + (tainted-value-labels val) + '())) + + ;; (untaint val) -> the underlying value, removing taint + ;; WARNING: only use after validation/sanitization + (define (untaint val) + (if (tainted-value? val) + (tainted-value-val val) + val)) + + ;; (untaint-with val sanitizer) -> sanitized value (unwrapped) + ;; Applies sanitizer to the raw value and returns the sanitized result. + (define (untaint-with val sanitizer) + (unless (procedure? sanitizer) + (error 'untaint-with "sanitizer must be a procedure" sanitizer)) + (let ([raw (untaint val)]) + (sanitizer raw))) + + ;; (propagate-taint source result) -> result possibly wrapped with source's labels + ;; If source is tainted, wraps result with the same labels. + (define (propagate-taint source result) + (if (tainted-value? source) + (taint result (tainted-value-labels source)) + result)) + + ;; ========== Taint Checking ========== + + ;; (check-not-tainted! who val) — raise taint-violation if val is tainted + (define (check-not-tainted! who val) + (when (tainted-value? val) + (let ([violation (list 'taint-violation who val (tainted-value-labels val))]) + (set! *current-violations* + (cons violation *current-violations*)) + (when (*taint-checking-enabled*) + (raise (condition + (make-error) + (make-message-condition + (format "taint violation in ~a: tainted value with labels ~a" + who + (map taint-label-name (tainted-value-labels val)))))))))) + + ;; (check-taint-label! who val label-name) — raise if val is tainted with specific label + (define (check-taint-label! who val label-name) + (when (tainted-value? val) + (let ([matching (filter (lambda (l) (eq? (taint-label-name l) label-name)) + (tainted-value-labels val))]) + (when (pair? matching) + (let ([violation (list 'taint-violation who val matching)]) + (set! *current-violations* + (cons violation *current-violations*)) + (when (*taint-checking-enabled*) + (raise (condition + (make-error) + (make-message-condition + (format "taint violation in ~a: value tainted with ~a" + who label-name)))))))))) + + ;; ========== Violations ========== + + (define *current-violations* '()) + + ;; *taint-violations* — parameter returning current violation list + (define *taint-violations* + (make-parameter '() + (lambda (v) v))) + + (define (reset-taint-violations!) + (set! *current-violations* '())) + + ;; Internal parameter tracking whether taint checking raises errors + (define *taint-checking-enabled* (make-parameter #f)) + + ;; (with-taint-checking thunk) — run thunk with taint checking enabled + (define-syntax with-taint-checking + (syntax-rules () + [(_ body ...) + (parameterize ([*taint-checking-enabled* #t]) + (reset-taint-violations!) + (let ([result (begin body ...)]) + result))])) + + ;; ========== Sink Declaration ========== + + ;; Sink registry: symbol -> #t + (define *sinks* (make-eq-hashtable)) + + ;; (define-sink name (lambda (arg ...) body ...)) + ;; Wraps the function so that any tainted argument triggers check-not-tainted! + (define-syntax define-sink + (lambda (stx) + (syntax-case stx () + [(_ name proc-expr) + #'(define name + (let ([underlying proc-expr]) + (lambda args + (for-each (lambda (arg) + (check-not-tainted! 'name arg)) + args) + (apply underlying args))))]))) + + ;; ========== Sanitizer Declaration ========== + + ;; (define-sanitizer name (lambda (x) ...)) + ;; Just an alias for define with documentation intent. + (define-syntax define-sanitizer + (syntax-rules () + [(_ name proc-expr) + (define name proc-expr)])) + + ;; ========== Built-in Sanitizers ========== + + ;; sql-escape: replace ' with '' (minimal SQL sanitization demo) + (define-sanitizer sql-escape + (lambda (s) + (unless (string? s) + (error 'sql-escape "expected string" s)) + (let ([chars (string->list s)]) + (list->string + (let loop ([rest chars] [acc '()]) + (if (null? rest) + (reverse acc) + (if (char=? (car rest) #\') + (loop (cdr rest) (cons #\' (cons #\' acc))) + (loop (cdr rest) (cons (car rest) acc))))))))) + + ;; html-escape: replace <, >, &, ", ' with HTML entities + (define-sanitizer html-escape + (lambda (s) + (unless (string? s) + (error 'html-escape "expected string" s)) + (let ([chars (string->list s)]) + (apply string-append + (map (lambda (c) + (cond + [(char=? c #\<) "<"] + [(char=? c #\>) ">"] + [(char=? c #\&) "&"] + [(char=? c #\") """] + [(char=? c #\') "'"] + [else (string c)])) + chars))))) + + ;; shell-escape: wrap in single quotes and escape single quotes + (define-sanitizer shell-escape + (lambda (s) + (unless (string? s) + (error 'shell-escape "expected string" s)) + (string-append + "'" + (let ([chars (string->list s)]) + (list->string + (let loop ([rest chars] [acc '()]) + (if (null? rest) + (reverse acc) + (if (char=? (car rest) #\') + ;; End quote, escaped quote, start quote + (loop (cdr rest) (append (reverse (string->list "'\\''")) acc)) + (loop (cdr rest) (cons (car rest) acc))))))) + "'"))) + + ;; ========== Taint Flow Report ========== + + ;; (taint-flow-report val) -> string describing the taint flow + (define (taint-flow-report val) + (if (not (tainted-value? val)) + "clean (not tainted)" + (let ([labels (tainted-value-labels val)]) + (string-append + "TAINTED with: " + (apply string-append + (map (lambda (l) + (string-append + (symbol->string (taint-label-name l)) + " [" (symbol->string (taint-label-severity l)) "] ")) + labels)))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/typed/effects.sls @@ -0,0 +1,242 @@ +#!chezscheme +;;; (std typed effects) — Enhanced effect typing (Phase 4b) +;;; +;;; Effect set tracking, effect polymorphism, and handler discharge. +;;; Extends the concepts in (std typed effect-typing) with full effect set algebra. + +(library (std typed effects) + (export + ;; Effect type constructor + Eff + make-eff-type + eff-type? + eff-type-effects + eff-type-return + ;; Effect set operations + effect-set-union + effect-set-intersect + effect-set-difference + effect-set-member? + empty-effect-set + ;; Annotated define + define/te + lambda/te + ;; Pure computation marker + Pure + pure? + ;; Effect discharge + discharge-effect + ;; Checking + check-effects! + infer-effects + *warn-unhandled-effects*) + + (import (chezscheme)) + + ;; ========== Effect Type: Tagged Vector ========== + ;; + ;; Use a tagged vector instead of define-record-type to avoid the constructor + ;; naming conflict between make-eff-type (user-facing with validation) and + ;; the raw record constructor. + ;; + ;; #(eff-type effects return) + + (define (make-eff-type effects return) + (unless (list? effects) + (error 'make-eff-type "effects must be a list of symbols" effects)) + (for-each (lambda (e) + (unless (symbol? e) + (error 'make-eff-type "each effect must be a symbol" e))) + effects) + (vector 'eff-type effects return)) + + (define (eff-type? x) + (and (vector? x) + (= (vector-length x) 3) + (eq? (vector-ref x 0) 'eff-type))) + + (define (eff-type-effects et) + (if (eff-type? et) + (vector-ref et 1) + (error 'eff-type-effects "not an eff-type" et))) + + (define (eff-type-return et) + (if (eff-type? et) + (vector-ref et 2) + (error 'eff-type-return "not an eff-type" et))) + + ;; ========== Effect Type Syntax ========== + + ;; (Eff (Effect ...) ReturnType) — construct an eff-type descriptor + (define-syntax Eff + (lambda (stx) + (syntax-case stx () + [(_ (effect ...) return-type) + #'(make-eff-type '(effect ...) 'return-type)]))) + + ;; (Pure T) — shorthand for (Eff () T) + (define-syntax Pure + (lambda (stx) + (syntax-case stx () + [(_ return-type) + #'(make-eff-type '() 'return-type)]))) + + ;; pure?: is an eff-type pure (empty effect set)? + (define (pure? x) + (and (eff-type? x) + (null? (eff-type-effects x)))) + + ;; ========== Effect Set Operations ========== + + (define empty-effect-set '()) + + ;; Union of two effect sets (remove duplicates) + (define (effect-set-union set1 set2) + (let loop ([rest set2] [result set1]) + (if (null? rest) + result + (if (memq (car rest) result) + (loop (cdr rest) result) + (loop (cdr rest) (cons (car rest) result)))))) + + ;; Intersection: effects present in both sets + (define (effect-set-intersect set1 set2) + (filter (lambda (e) (memq e set2)) set1)) + + ;; Difference: effects in set1 but not set2 + (define (effect-set-difference set1 set2) + (filter (lambda (e) (not (memq e set2))) set1)) + + ;; Membership test + (define (effect-set-member? effect set) + (if (memq effect set) #t #f)) + + ;; ========== Effect Discharge ========== + + ;; (discharge-effect eff-type effect-name) -> new eff-type with effect removed + (define (discharge-effect et effect) + (unless (eff-type? et) + (error 'discharge-effect "not an eff-type" et)) + (unless (symbol? effect) + (error 'discharge-effect "effect must be a symbol" effect)) + (make-eff-type (filter (lambda (e) (not (eq? e effect))) + (eff-type-effects et)) + (eff-type-return et))) + + ;; ========== Effect Checking ========== + + ;; *warn-unhandled-effects* — parameter controlling warning behavior + ;; Defined before check-effects! to avoid forward reference issues + (define *warn-unhandled-effects* + (make-parameter #f + (lambda (v) + (if (boolean? v) v + (error '*warn-unhandled-effects* "must be boolean" v))))) + + ;; (check-effects! eff-type handled-list) -> boolean + ;; Returns #t if all effects are handled, #f otherwise. + ;; When *warn-unhandled-effects* is #t, emits warnings for missing effects. + (define (check-effects! et handled) + (unless (eff-type? et) + (error 'check-effects! "not an eff-type" et)) + (unless (list? handled) + (error 'check-effects! "handled must be a list of symbols" handled)) + (let ([unhandled (effect-set-difference (eff-type-effects et) handled)]) + (when (and (pair? unhandled) (*warn-unhandled-effects*)) + (for-each (lambda (e) + (fprintf (current-error-port) + "WARNING: unhandled effect: ~a~%" e)) + unhandled)) + (null? unhandled))) + + ;; ========== Effect Inference ========== + + ;; (infer-effects expr) -> list of effect symbols + ;; + ;; Static analysis of a quoted expression for effect-like calls. + ;; Looks for patterns where a symbol starting with uppercase is called + ;; as a function: (EffName op args...) or (perform (EffName op ...)) + (define (infer-effects expr) + (let ([effects '()]) + (define (visit form) + (cond + [(and (pair? form) (symbol? (car form))) + (let* ([head (car form)] + [head-str (symbol->string head)]) + ;; Heuristic: symbols starting with uppercase that look like effect names + (when (and (> (string-length head-str) 0) + (char-upper-case? (string-ref head-str 0)) + (not (memq head '(Eff Pure Row)))) + (unless (memq head effects) + (set! effects (cons head effects)))) + ;; Recurse into subforms + (for-each visit (cdr form)))] + [(pair? form) + (for-each visit form)] + [else (void)])) + (visit expr) + effects)) + + ;; ========== Annotated Define ========== + + ;; Registry: function name (symbol) -> eff-type + (define *effect-annotations* (make-eq-hashtable)) + + ;; (define/te (name [arg : type] ...) : (Eff [effects...] ReturnType) body ...) + ;; + ;; If the return type annotation is an Eff or Pure form, registers the + ;; effect annotation. Otherwise acts like a plain define. + (define-syntax define/te + (lambda (stx) + ;; Inline helper: is a datum an Eff or Pure form? + (define (eff-type-form? d) + (and (pair? d) + (or (eq? (car d) 'Eff) (eq? (car d) 'Pure)))) + + (define (strip-type-annot arg-stx) + (syntax-case arg-stx () + [(aname : atype) + (eq? (syntax->datum #':) ':) + #'aname] + [aname + (identifier? #'aname) + #'aname])) + + (syntax-case stx () + ;; With return type annotation + [(_ (name arg ...) : ret-type body ...) + (let* ([ret-datum (syntax->datum #'ret-type)] + [is-eff? (eff-type-form? ret-datum)] + [plain-args (map strip-type-annot (syntax->list #'(arg ...)))]) + (with-syntax ([(aname ...) plain-args]) + (if is-eff? + #'(begin + (define (name aname ...) body ...) + (hashtable-set! *effect-annotations* 'name ret-type)) + #'(define (name aname ...) body ...))))] + ;; Without return type — plain define + [(_ (name arg ...) body ...) + (let ([plain-args (map strip-type-annot (syntax->list #'(arg ...)))]) + (with-syntax ([(aname ...) plain-args]) + #'(define (name aname ...) body ...)))]))) + + ;; (lambda/te (args ...) : (Eff [...] T) body ...) + (define-syntax lambda/te + (lambda (stx) + (define (strip-type-annot arg-stx) + (syntax-case arg-stx () + [(aname : atype) + (eq? (syntax->datum #':) ':) + #'aname] + [aname + (identifier? #'aname) + #'aname])) + (syntax-case stx () + [(_ (arg ...) : ret-type body ...) + (with-syntax ([(aname ...) (map strip-type-annot (syntax->list #'(arg ...)))]) + #'(lambda (aname ...) body ...))] + [(_ (arg ...) body ...) + (with-syntax ([(aname ...) (map strip-type-annot (syntax->list #'(arg ...)))]) + #'(lambda (aname ...) body ...))]))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/typed/hkt.sls @@ -0,0 +1,353 @@ +#!chezscheme +;;; (std typed hkt) — Higher-Kinded Types (HKT) +;;; +;;; Provides type classes that abstract over type constructors (f :: * -> *). +;;; Instances are registered by a type-constructor tag (a symbol like 'Option). +;;; +;;; API: +;;; (defprotocol-hkt Name (method arg ...) ...) — define an HKT class +;;; (implement-hkt Name tag (method impl) ...) — register an instance +;;; (hkt-instance Name tag) — look up instance or #f +;;; (hkt-instance? Name tag) — predicate +;;; +;;; Built-in classes: Functor Applicative Monad Foldable Traversable +;;; do/m macro for monadic do-notation +;;; +;;; Option type: make-Some make-None Some? None? Some-val +;;; option-fmap option-bind option-return +;;; Result type: make-Ok make-Err Ok? Err? Ok-val Err-val +;;; result-fmap result-bind result-return + +(library (std typed hkt) + (export + ;; Protocol / instance machinery + defprotocol-hkt + implement-hkt + hkt-instance + hkt-instance? + hkt-dispatch + + ;; Built-in HKT classes + Functor + Applicative + Monad + Foldable + Traversable + + ;; do/m notation + do/m + + ;; Option type + make-Some + make-None + Some? + None? + Some-val + option-fmap + option-bind + option-return + + ;; Result type + make-Ok + make-Err + Ok? + Err? + Ok-val + Err-val + result-fmap + result-bind + result-return) + + (import (chezscheme)) + + ;; ========== HKT Registry ========== + ;; + ;; *hkt-registry* : class-name-sym -> class-descriptor + ;; class-descriptor: vector of (name methods instances-hashtable) + + (define *hkt-registry* (make-eq-hashtable)) + + (define (make-hkt-class-descriptor name methods) + (vector 'hkt-class name methods (make-eq-hashtable))) + + (define (hkt-class-descriptor? v) + (and (vector? v) (= (vector-length v) 4) (eq? (vector-ref v 0) 'hkt-class))) + + (define (hkt-cd-name cd) (vector-ref cd 1)) + (define (hkt-cd-methods cd) (vector-ref cd 2)) + (define (hkt-cd-instances cd) (vector-ref cd 3)) + + ;; ========== Instance lookup ========== + + (define (hkt-instance class-name type-tag) + (let ([cd (hashtable-ref *hkt-registry* class-name #f)]) + (if cd + (hashtable-ref (hkt-cd-instances cd) type-tag #f) + #f))) + + (define (hkt-instance? class-name type-tag) + (and (hkt-instance class-name type-tag) #t)) + + ;; ========== defprotocol-hkt ========== + ;; + ;; (defprotocol-hkt Name (method arg ...) ...) + ;; Registers the HKT class in *hkt-registry*. + + (define-syntax defprotocol-hkt + (lambda (stx) + (syntax-case stx () + [(_ ClassName (method-name arg ...) ...) + (let ([class-sym (syntax->datum #'ClassName)]) + (with-syntax ([csym (datum->syntax #'ClassName class-sym)] + [(msym ...) (map (lambda (m) + (datum->syntax m (syntax->datum m))) + (syntax->list #'(method-name ...)))]) + #'(define ClassName + (let ([cd (make-hkt-class-descriptor 'csym '(msym ...))]) + (hashtable-set! *hkt-registry* 'csym cd) + cd))))]))) + + ;; ========== implement-hkt ========== + ;; + ;; (implement-hkt ClassName type-tag (method-name impl) ...) + ;; Registers an instance for a given type constructor tag. + + (define-syntax implement-hkt + (lambda (stx) + (syntax-case stx () + [(_ ClassName type-tag (method-name impl) ...) + (let ([class-sym (syntax->datum #'ClassName)] + [type-sym (syntax->datum #'type-tag)]) + (with-syntax ([csym (datum->syntax #'ClassName class-sym)] + [tsym (datum->syntax #'type-tag type-sym)] + [reg-var (datum->syntax #'ClassName + (string->symbol + (string-append "%hkt-instance-" + (symbol->string class-sym) "-" + (symbol->string type-sym) "%")))] + [(msym ...) (map (lambda (m) + (datum->syntax m (syntax->datum m))) + (syntax->list #'(method-name ...)))]) + ;; Expand to a define so we stay in definition context + #'(define reg-var + (let* ([cd (or (hashtable-ref *hkt-registry* 'csym #f) + (error 'implement-hkt "unknown HKT class" 'csym))] + [inst (make-eq-hashtable)]) + (hashtable-set! inst 'msym impl) ... + (hashtable-set! (hkt-cd-instances cd) 'tsym inst) + inst))))]))) + + ;; ========== HKT method dispatch ========== + + (define (hkt-dispatch class-sym method-sym type-tag . args) + (let* ([cd (or (hashtable-ref *hkt-registry* class-sym #f) + (error 'hkt-dispatch "unknown HKT class" class-sym))] + [inst (or (hashtable-ref (hkt-cd-instances cd) type-tag #f) + (error 'hkt-dispatch "no instance for type tag" type-tag class-sym))] + [proc (or (hashtable-ref inst method-sym #f) + (error 'hkt-dispatch "method not found" method-sym class-sym))]) + (apply proc args))) + + ;; ========== Built-in HKT Classes ========== + + (defprotocol-hkt Functor + (fmap f fa)) + + (defprotocol-hkt Applicative + (pure a) + (ap ff fa)) + + (defprotocol-hkt Monad + (bind ma f) + (return a)) +