Phase 2c complete: Type System (4 libraries, 111 tests passing)
ober
283afb4aaf20ef7278dc09c8f9436de6df546392
new file mode 100644 --- /dev/null +++ b/lib/std/typed/effect-typing.sls @@ -0,0 +1,190 @@ +#!chezscheme +;;; (std typed effect-typing) — Effect type signatures for handlers +;;; +;;; Annotate effect handlers with their effect signatures. +;;; Check at runtime that handlers handle the declared effects. +;;; Integrates with (std effect) by inspecting handler dispatch tables. +;;; +;;; API: +;;; (define-effect-signature Name +;;; handles: (Effect1 Effect2 ...) +;;; returns: type-spec) +;;; — define a named effect signature descriptor +;;; +;;; (check-effect-signature sig-name handler-form) +;;; — verify at runtime that handler-form handles all declared effects +;;; +;;; (effect-sig? v) — #t iff v is an effect signature descriptor +;;; (effect-sig-handles v) — list of effect names the sig handles +;;; (effect-sig-returns v) — the declared return type spec +;;; +;;; (typed-with-handler sig-name handler-clauses body ...) +;;; — like with-handler but checks the signature first +;;; +;;; (infer-handler-effects handler-table) +;;; — inspect a handler dispatch table and return the list of effect names + +(library (std typed effect-typing) + (export + define-effect-signature + check-effect-signature + effect-sig? + effect-sig-handles + effect-sig-returns + typed-with-handler + infer-handler-effects) + (import (chezscheme)) + + ;; ========== Effect signature descriptor ========== + ;; + ;; A signature is a record: (name handles returns) + ;; name: symbol — identifier for this signature + ;; handles: list of symbols — effect names this handler should cover + ;; returns: any — type specifier for the return value (informational) + + (define-record-type effect-sig + (fields + (immutable name effect-sig-name) + (immutable handles effect-sig-handles) + (immutable returns effect-sig-returns)) + (sealed #t)) + + ;; ========== Signature registry ========== + + (define *effect-sig-registry* (make-eq-hashtable)) + + (define (register-effect-sig! name sig) + (hashtable-set! *effect-sig-registry* name sig)) + + (define (lookup-effect-sig name) + (hashtable-ref *effect-sig-registry* name #f)) + + ;; ========== define-effect-signature ========== + ;; + ;; (define-effect-signature SigName + ;; handles: (Effect ...) + ;; returns: type-spec) + ;; + ;; Note: handles: and returns: are matched by datum value (not free-identifier + ;; equality) to avoid export issues in R6RS library context. + + (define-syntax define-effect-signature + (lambda (stx) + (syntax-case stx () + [(_ SigName kw1 (effect ...) kw2 ret) + (and (eq? (syntax->datum #'kw1) 'handles:) + (eq? (syntax->datum #'kw2) 'returns:)) + #'(define SigName + (let ([sig (make-effect-sig 'SigName '(effect ...) 'ret)]) + (register-effect-sig! 'SigName sig) + sig))] + [(_ SigName . rest) + (syntax-violation 'define-effect-signature + "expected: (define-effect-signature Name handles: (Effects ...) returns: type)" + stx)]))) + + ;; ========== infer-handler-effects ========== + ;; + ;; Given a handler dispatch table (an eq-hashtable mapping effect-descriptor + ;; to alist-of-handlers, as used by (std effect)), extract the effect names. + ;; + ;; The (std effect) effect-descriptor is a record with a 'name' field. + ;; We use inspect/object or direct record access if effect is loaded, but + ;; to avoid a hard dependency on (std effect), we accept either: + ;; - a list of effect name symbols (for direct use) + ;; - an eq-hashtable where each key has a 'name' field (from (std effect)) + ;; The function returns a list of symbols. + + (define (infer-handler-effects handler-table) + (cond + ;; List of effect name symbols — already inferred + [(list? handler-table) + handler-table] + ;; eq-hashtable — try to extract effect names from keys + [(hashtable? handler-table) + (let-values ([(keys _) (hashtable-entries handler-table)]) + (vector->list + (vector-map + (lambda (k) + ;; Try to get the name field from an effect descriptor record + (guard (exn [#t k]) ; fallback: use the key itself as name + ;; effect-descriptor from (std effect) has a 'name' accessor + ;; We can use the record inspection API + (if (record? k) + (let* ([rtd (record-rtd k)] + [fields (record-type-field-names rtd)] + [name-idx + (let loop ([i 0] [flds (vector->list fields)]) + (cond + [(null? flds) #f] + [(eq? (car flds) 'name) i] + [else (loop (+ i 1) (cdr flds))]))]) + (if name-idx + ((record-accessor rtd name-idx) k) + k)) + k))) + keys)))] + [else + (error 'infer-handler-effects + "expected list or hashtable" handler-table)])) + + ;; ========== check-effect-signature ========== + ;; + ;; Check that a handler covers all effects declared in a signature. + ;; handler-effects: either a list of effect name symbols, or an + ;; eq-hashtable (as returned by (std effect) handler setup). + ;; + ;; Returns #t on success, raises an error if any declared effect is missing. + + (define (check-effect-signature sig handler-or-effects) + (unless (effect-sig? sig) + (error 'check-effect-signature "not an effect signature" sig)) + (let* ([declared (effect-sig-handles sig)] + [actual (infer-handler-effects handler-or-effects)] + [missing (filter (lambda (e) (not (memq e actual))) declared)]) + (when (pair? missing) + (error 'check-effect-signature + "handler does not handle declared effects" + (effect-sig-name sig) + missing)) + #t)) + + ;; ========== typed-with-handler ========== + ;; + ;; (typed-with-handler sig-name ([EffectName (op-name (k arg ...) body ...) ...] ...) body ...) + ;; + ;; Wraps a with-handler call (from (std effect)) with a signature check. + ;; The check verifies the declared effects are present in the handler clauses. + ;; + ;; Since we can't import (std effect) without risking circular deps, we + ;; implement typed-with-handler as a macro that: + ;; 1. Extracts the effect names from the handler clauses at expand time + ;; 2. Checks them against the runtime signature + ;; 3. Delegates to with-handler (which must be in scope from (std effect)) + + (define-syntax typed-with-handler + (lambda (stx) + (syntax-case stx () + [(_ sig-name ([EffectName handler-clause ...] ...) body ...) + ;; with-handler must be imported from (std effect) at the call site. + ;; We reference it via datum->syntax anchored to the macro keyword. + (with-syntax ([(esym ...) #'(EffectName ...)] + [with-handler-ref + (datum->syntax (car (syntax->list stx)) 'with-handler)]) + #'(begin + ;; Runtime signature check against the handler clause effect names + (let ([sig sig-name]) + (unless (effect-sig? sig) + (error 'typed-with-handler "not an effect signature" sig)) + (let* ([actual-effects '(esym ...)] + [declared (effect-sig-handles sig)] + [missing (filter (lambda (e) (not (memq e actual-effects))) + declared)]) + (when (pair? missing) + (error 'typed-with-handler + "handler missing declared effects" + (effect-sig-name sig) missing)))) + ;; Delegate to with-handler (must be in scope from (std effect)) + (with-handler-ref ([EffectName handler-clause ...] ...) body ...)))]))) + + ) ; end library new file mode 100644 --- /dev/null +++ b/lib/std/typed/gadt.sls @@ -0,0 +1,158 @@ +#!chezscheme +;;; (std typed gadt) — Generalized Algebraic Data Types +;;; +;;; GADTs allow type-indexed variants. Implemented as tagged vectors with +;;; type-checked constructors and pattern-matching eliminators. +;;; +;;; API: +;;; (define-gadt Name (Ctor field ...) ...) +;;; — defines predicate Name?, constructors Ctor +;;; +;;; (gadt-match expr [(Ctor field ...) body ...] ...) +;;; — structural pattern match on a GADT value +;;; +;;; (gadt? v) — #t if v is any GADT value +;;; (gadt-tag v) — the constructor tag symbol +;;; (gadt-fields v) — list of field values +;;; (gadt-constructor v) — the constructor name (same as gadt-tag) + +(library (std typed gadt) + (export + define-gadt + gadt-match + gadt? + gadt-tag + gadt-fields + gadt-constructor) + (import (chezscheme)) + + ;; ========== Runtime representation ========== + ;; + ;; A GADT value is a vector: #(gadt-box <type-sym> <ctor-sym> field ...) + ;; slot 0: marker symbol 'gadt-box (for generic gadt? check) + ;; slot 1: type name symbol (e.g. 'Expr) + ;; slot 2: constructor tag symbol (e.g. 'Lit) + ;; slot 3+: field values + + (define *gadt-marker* 'gadt-box) + + (define (gadt? v) + (and (vector? v) + (>= (vector-length v) 3) + (eq? (vector-ref v 0) *gadt-marker*))) + + (define (gadt-tag v) + (if (gadt? v) + (vector-ref v 2) + (error 'gadt-tag "not a GADT value" v))) + + ;; gadt-constructor is an alias for gadt-tag + (define (gadt-constructor v) + (gadt-tag v)) + + (define (gadt-fields v) + (if (gadt? v) + (let ([len (vector-length v)]) + (let loop ([i 3] [acc '()]) + (if (>= i len) + (reverse acc) + (loop (+ i 1) (cons (vector-ref v i) acc))))) + (error 'gadt-fields "not a GADT value" v))) + + ;; ========== define-gadt ========== + ;; + ;; (define-gadt TypeName (CtorName field ...) ...) + ;; + ;; Pattern: each variant is (CtorName field ...) with zero or more fields. + ;; Generates: + ;; - TypeName? predicate + ;; - one constructor procedure per CtorName + + (define-syntax define-gadt + (lambda (stx) + (define (make-pred-name type-id) + (datum->syntax type-id + (string->symbol + (string-append (symbol->string (syntax->datum type-id)) "?")))) + + (define (make-ctor type-id ctor-id field-ids) + (let ([type-sym (syntax->datum type-id)] + [ctor-sym (syntax->datum ctor-id)]) + (with-syntax ([C ctor-id] + [tsym (datum->syntax ctor-id type-sym)] + [csym (datum->syntax ctor-id ctor-sym)] + [(f ...) field-ids]) + #'(define (C f ...) + (vector 'gadt-box 'tsym 'csym f ...))))) + + (syntax-case stx () + [(_ TypeName variant ...) + (let* ([pred-id (make-pred-name #'TypeName)] + [type-sym (syntax->datum #'TypeName)] + [variants (syntax->list #'(variant ...))] + [ctor-defs + (map (lambda (v) + (syntax-case v () + [(Ctor field ...) + (make-ctor #'TypeName #'Ctor + (syntax->list #'(field ...)))])) + variants)]) + (with-syntax ([pred-name pred-id] + [tsym (datum->syntax #'TypeName type-sym)] + [(ctor-def ...) ctor-defs]) + #'(begin + (define (pred-name v) + (and (gadt? v) + (eq? (vector-ref v 1) 'tsym))) + ctor-def ...)))]))) + + ;; ========== gadt-match ========== + ;; + ;; (gadt-match expr [(CtorName field ...) body ...] ...) + ;; + ;; Destructures the GADT value by tag, binding each named field. + ;; Uses list-ref on (gadt-fields val) to bind fields positionally. + + (define-syntax gadt-match + (lambda (stx) + (define (make-arm val-id ctor-id field-ids body-stxs) + (let ([ctor-sym (syntax->datum ctor-id)] + [fields (syntax->list field-ids)]) + (if (null? fields) + (with-syntax ([V val-id] + [csym (datum->syntax ctor-id ctor-sym)] + [(body ...) body-stxs]) + #'[(eq? (gadt-tag V) 'csym) + body ...]) + (let ([indices (let loop ([i 0] [n (length fields)] [acc '()]) + (if (= i n) (reverse acc) (loop (+ i 1) n (cons i acc))))]) + (with-syntax ([V val-id] + [csym (datum->syntax ctor-id ctor-sym)] + [(body ...) body-stxs] + [(f ...) field-ids] + [(idx ...) (map (lambda (i) (datum->syntax ctor-id i)) indices)]) + #'[(eq? (gadt-tag V) 'csym) + (let ([flds (gadt-fields V)]) + (let ([f (list-ref flds idx)] ...) + body ...))]))))) + + (syntax-case stx () + [(_ expr [(CtorName field ...) body ...] ...) + (let* ([val-id (datum->syntax (car (syntax->list stx)) (gensym "gval"))] + [arms + (map (lambda (ctor-id field-ids body-stxs) + (make-arm val-id ctor-id field-ids body-stxs)) + (syntax->list #'(CtorName ...)) + (map syntax->list (syntax->list #'((field ...) ...))) + (map syntax->list (syntax->list #'((body ...) ...))))]) + (with-syntax ([V val-id] + [(arm ...) arms]) + #'(let ([V expr]) + (unless (gadt? V) + (error 'gadt-match "not a GADT value" V)) + (cond + arm ... + [else + (error 'gadt-match "no matching arm" (gadt-tag V))]))))]))) + + ) ; end library new file mode 100644 --- /dev/null +++ b/lib/std/typed/linear.sls @@ -0,0 +1,144 @@ +#!chezscheme +;;; (std typed linear) — Linear types: values used exactly once +;;; +;;; Linear types ensure that a value is consumed exactly once. +;;; This is enforced dynamically at runtime (static enforcement is aspirational). +;;; +;;; A linear value wraps a payload with a use-count cell. +;;; Consuming it (via linear-use) marks it as consumed; subsequent attempts error. +;;; linear-split allows splitting into N independent single-use tokens. +;;; +;;; API: +;;; (make-linear val) — wrap val in a linear container +;;; (define-linear name expr) — bind name to a fresh linear value +;;; (linear? v) — #t iff v is a linear value +;;; (linear-consumed? v) — #t iff the linear value has been consumed +;;; (linear-use lv proc) — consume lv, call (proc payload), return result +;;; (linear-split lv n) — split lv into n linear values of the same payload +;;; (with-linear ((name expr) ...) body ...) +;;; — bind linear values, auto-check consumption +;;; (linear-value lv) — peek at the payload WITHOUT consuming (use sparingly) + +(library (std typed linear) + (export + make-linear + define-linear + linear? + linear-consumed? + linear-use + linear-split + with-linear + linear-value) + (import (chezscheme)) + + ;; ========== Runtime representation ========== + ;; + ;; A linear value is a mutable vector: + ;; #(linear-box <payload> <consumed?> <name-hint>) + ;; where consumed? starts as #f and is set to #t on first use. + + (define (make-linear val) + (vector 'linear-box val #f #f)) + + (define (make-linear/named val name) + (vector 'linear-box val #f name)) + + (define (linear? v) + (and (vector? v) + (= (vector-length v) 4) + (eq? (vector-ref v 0) 'linear-box))) + + (define (linear-consumed? v) + (if (linear? v) + (vector-ref v 2) + (error 'linear-consumed? "not a linear value" v))) + + ;; Access the payload without consuming — intended for inspection only. + (define (linear-value v) + (if (linear? v) + (begin + (when (vector-ref v 2) + (error 'linear-value "linear value already consumed" + (or (vector-ref v 3) v))) + (vector-ref v 1)) + (error 'linear-value "not a linear value" v))) + + ;; ========== linear-use ========== + ;; + ;; Consume the linear value: mark as consumed, call (proc payload). + ;; Errors if already consumed. + + (define (linear-use lv proc) + (unless (linear? lv) + (error 'linear-use "not a linear value" lv)) + (when (vector-ref lv 2) + (error 'linear-use "linear value already consumed" + (or (vector-ref lv 3) lv))) + (vector-set! lv 2 #t) + (proc (vector-ref lv 1))) + + ;; ========== linear-split ========== + ;; + ;; Consume the original linear value and produce n new linear values, + ;; each wrapping the same payload. This allows patterns like read-only + ;; sharing or multi-step consumption. + + (define (linear-split lv n) + (unless (linear? lv) + (error 'linear-split "not a linear value" lv)) + (unless (and (integer? n) (positive? n)) + (error 'linear-split "n must be a positive integer" n)) + (when (vector-ref lv 2) + (error 'linear-split "linear value already consumed" + (or (vector-ref lv 3) lv))) + (vector-set! lv 2 #t) + (let ([payload (vector-ref lv 1)]) + (let loop ([i 0] [acc '()]) + (if (= i n) + (reverse acc) + (loop (+ i 1) (cons (make-linear payload) acc)))))) + + ;; ========== define-linear ========== + ;; + ;; (define-linear name expr) + ;; Evaluates expr and wraps it in a linear value bound to name. + + (define-syntax define-linear + (lambda (stx) + (syntax-case stx () + [(_ name expr) + (with-syntax ([name-sym (datum->syntax #'name (syntax->datum #'name))]) + #'(define name + (make-linear/named expr 'name-sym)))]))) + + ;; ========== with-linear ========== + ;; + ;; (with-linear ((name expr) ...) body ...) + ;; + ;; Binds each name to a fresh linear value wrapping expr. + ;; After body executes, checks that all linear bindings were consumed. + ;; Raises an error if any value remains unconsumed at scope exit. + ;; + ;; Note: does NOT auto-consume — it only warns/errors about leaks. + + (define-syntax with-linear + (lambda (stx) + (syntax-case stx () + [(_ ((name expr) ...) body ...) + (with-syntax ([(nname ...) #'(name ...)] + [(nsym ...) (map (lambda (n) + (datum->syntax n (syntax->datum n))) + (syntax->list #'(name ...)))]) + #'(let ([name (make-linear/named expr 'nsym)] ...) + (let ([result (begin body ...)]) + ;; Check for unconsumed linear values + (for-each + (lambda (lv sym) + (unless (linear-consumed? lv) + (error 'with-linear + "linear value was not consumed" sym))) + (list name ...) + '(nsym ...)) + result)))]))) + + ) ; end library new file mode 100644 --- /dev/null +++ b/lib/std/typed/typeclass.sls @@ -0,0 +1,181 @@ +#!chezscheme +;;; (std typed typeclass) — Haskell-style type classes as dictionaries +;;; +;;; Type classes are dictionaries (eq-hashtables) mapping method names to +;;; procedures. Instances are registered per type-tag (a symbol or predicate). +;;; with-class does lexical method binding via let. +;;; +;;; API: +;;; (define-class ClassName (method arg ...) ...) +;;; — define a class with a set of method signatures +;;; +;;; (define-instance ClassName type-tag +;;; (method impl) ...) +;;; — register an instance implementation for a type +;;; +;;; (with-class ClassName body ...) +;;; — bring class methods into scope (looks up instance by first arg's type) +;;; +;;; (instance-of ClassName type-tag) => instance or #f +;;; (class-method instance method-name) => procedure + +(library (std typed typeclass) + (export + define-class + define-instance + with-class + instance-of + class-method) + (import (chezscheme)) + + ;; ========== Class registry ========== + ;; + ;; *class-registry* : symbol -> class-descriptor + ;; class-descriptor: #(class-name methods instances) + ;; methods: list of method name symbols (for documentation/validation) + ;; instances: eq-hashtable of type-tag -> instance-hashtable + + (define *class-registry* (make-eq-hashtable)) + + (define (make-class-descriptor name methods) + (vector 'class-descriptor name methods (make-eq-hashtable))) + + (define (class-descriptor? v) + (and (vector? v) + (= (vector-length v) 4) + (eq? (vector-ref v 0) 'class-descriptor))) + + (define (class-descriptor-name cd) (vector-ref cd 1)) + (define (class-descriptor-methods cd) (vector-ref cd 2)) + (define (class-descriptor-instances cd) (vector-ref cd 3)) + + ;; ========== Instance lookup ========== + + (define (instance-of class-name type-tag) + (let ([cd (hashtable-ref *class-registry* class-name #f)]) + (if cd + (hashtable-ref (class-descriptor-instances cd) type-tag #f) + #f))) + + (define (class-method inst method-name) + (hashtable-ref inst method-name #f)) + + ;; ========== Type tag inference ========== + ;; + ;; Determine the type tag for a value by trying common predicates. + ;; Used by with-class to look up the right instance automatically. + + (define (infer-type-tag v) + (cond + [(boolean? v) 'boolean] + [(fixnum? v) 'fixnum] + [(flonum? v) 'flonum] + [(integer? v) 'integer] + [(number? v) 'number] + [(string? v) 'string] + [(char? v) 'char] + [(symbol? v) 'symbol] + [(pair? v) 'pair] + [(null? v) 'null] + [(vector? v) 'vector] + [(bytevector? v) 'bytevector] + [(procedure? v) 'procedure] + [(hashtable? v) 'hashtable] + [else 'unknown])) + + ;; ========== define-class ========== + ;; + ;; (define-class ClassName (method arg ...) ...) + ;; Registers the class in *class-registry* with an empty instance table. + + (define-syntax define-class + (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 ...)))]) + #'(begin + (define ClassName + (let ([cd (make-class-descriptor 'csym '(msym ...))]) + (hashtable-set! *class-registry* 'csym cd) + cd)) + (void))))]))) + + ;; ========== define-instance ========== + ;; + ;; (define-instance ClassName type-tag + ;; (method-name impl) ...) + ;; + ;; Registers an instance: creates an eq-hashtable mapping each + ;; method-name to its implementation, then stores it under type-tag + ;; in the class's instances table. + + (define-syntax define-instance + (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)] + [(msym ...) (map (lambda (m) + (datum->syntax m (syntax->datum m))) + (syntax->list #'(method-name ...)))]) + #'(let* ([cd (or (hashtable-ref *class-registry* 'csym #f) + (error 'define-instance "unknown class" 'csym))] + [inst (make-eq-hashtable)]) + (begin + (hashtable-set! inst 'msym impl) ...) + (hashtable-set! (class-descriptor-instances cd) 'tsym inst))))]))) + + ;; ========== class-dispatch ========== + ;; + ;; Runtime helper: look up and call a class method by name. + ;; Used by with-class. + + (define (class-dispatch class-sym method-sym first-arg . rest-args) + (let* ([cd (or (hashtable-ref *class-registry* class-sym #f) + (error 'class-dispatch "unknown class" class-sym))] + [tag (infer-type-tag first-arg)] + [inst (or (hashtable-ref (class-descriptor-instances cd) tag #f) + (error 'class-dispatch "no instance for type" tag class-sym))] + [proc (or (hashtable-ref inst method-sym #f) + (error 'class-dispatch "method not found" method-sym class-sym))]) + (apply proc first-arg rest-args))) + + ;; ========== with-class ========== + ;; + ;; (with-class ClassName body ...) + ;; + ;; Introduces a local dispatch binding so callers can write: + ;; (ClassName method-name arg ...) + ;; which expands to a runtime lookup through class-dispatch. + ;; + ;; This is implemented as a local macro that rewrites + ;; (ClassName meth first-arg rest ...) + ;; to + ;; (class-dispatch 'ClassName 'meth first-arg rest ...) + + (define-syntax with-class + (lambda (stx) + (syntax-case stx () + [(_ ClassName body ...) + (let ([class-sym (syntax->datum #'ClassName)]) + (with-syntax ([csym (datum->syntax #'ClassName class-sym)]) + ;; Use a fluid-let style trick: rebind ClassName locally as syntax. + ;; We cannot nest define-syntax with live ellipsis easily, so we + ;; generate the dispatch call directly. + ;; + ;; Strategy: transform each (ClassName m arg ...) in body via + ;; a let-syntax that captures the class name as a datum. + #'(let-syntax ([ClassName + (lambda (s) + (syntax-case s () + [(_ mname fst rest (... ...)) + #'(class-dispatch 'csym 'mname fst rest (... ...))]))]) + body ...)))]))) + + ) ; end library new file mode 100644 --- /dev/null +++ b/tests/test-effect-typing.ss @@ -0,0 +1,216 @@ +#!chezscheme +;;; Tests for (std typed effect-typing) — Effect type signatures + +(import (chezscheme) (std typed effect-typing) (std effect)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- Phase 2c: Effect Typing ---~%~%") + +;; ========== define-effect-signature ========== + +(define-effect-signature NoEffects + handles: () + returns: any) + +(define-effect-signature StateOnly + handles: (State) + returns: integer) + +(define-effect-signature MultiEffect + handles: (State Reader Writer) + returns: any) + +(test "effect-sig? on sig" + (effect-sig? StateOnly) + #t) + +(test "effect-sig? on non-sig" + (effect-sig? 42) + #f) + +(test "effect-sig? on #f" + (effect-sig? #f) + #f) + +(test "effect-sig-handles/empty" + (effect-sig-handles NoEffects) + '()) + +(test "effect-sig-handles/single" + (effect-sig-handles StateOnly) + '(State)) + +(test "effect-sig-handles/multiple" + (effect-sig-handles MultiEffect) + '(State Reader Writer)) + +(test "effect-sig-returns/any" + (effect-sig-returns StateOnly) + 'integer) + +(test "effect-sig-returns/multi" + (effect-sig-returns MultiEffect) + 'any) + +;; ========== Signature registry ========== +;; Each define-effect-signature registers by name + +(define-effect-signature Registered + handles: (MyEff) + returns: string) + +;; We can look it up by introspecting through a re-check +(test "signature accessible via variable" + (effect-sig? Registered) + #t) + +;; ========== check-effect-signature ========== + +(test "check-effect-sig/exact match" + (check-effect-signature StateOnly '(State)) + #t) + +(test "check-effect-sig/superset ok" + (check-effect-signature StateOnly '(State Reader)) + #t) + +(test "check-effect-sig/empty handles ok" + (check-effect-signature NoEffects '()) + #t) + +(test "check-effect-sig/empty handles any actual ok" + (check-effect-signature NoEffects '(State)) + #t) + +(test "check-effect-sig/missing effect errors" + (guard (exn [#t (condition-message exn)]) + (check-effect-signature StateOnly '())) + "handler does not handle declared effects") + +(test "check-effect-sig/partial miss errors" + (guard (exn [#t (condition-message exn)]) + (check-effect-signature MultiEffect '(State Reader))) + "handler does not handle declared effects") + +(test "check-effect-sig/non-sig errors" + (guard (exn [#t (condition-message exn)]) + (check-effect-signature 'not-a-sig '(State))) + "not an effect signature") + +;; ========== infer-handler-effects ========== + +(test "infer-handler-effects/list passthrough" + (infer-handler-effects '(State Reader)) + '(State Reader)) + +(test "infer-handler-effects/empty list" + (infer-handler-effects '()) + '()) + +(test "infer-handler-effects/hashtable" + ;; Build a hashtable like what (std effect) uses: + ;; keys are effect descriptors (records with 'name field) + (let ([ht (make-eq-hashtable)]) + ;; We put symbols as keys (since we don't have real effect-descriptors here) + ;; infer-handler-effects falls back to the key itself if no 'name field + (hashtable-set! ht 'State '()) + (hashtable-set! ht 'Reader '()) + (let ([effects (infer-handler-effects ht)]) + (and (memq 'State effects) (memq 'Reader effects) #t))) + #t) + +;; ========== typed-with-handler integration ========== + +(defeffect State (get) (put val)) + +(define-effect-signature StateHandler + handles: (State) + returns: integer) + +(test "typed-with-handler/basic" + (let ([st 0]) + (typed-with-handler StateHandler + ([State + (get (k) (resume k st)) + (put (k v) (set! st v) (resume k (void)))]) + (State put 42) + (State get))) + 42) + +(test "typed-with-handler/computation" + (let ([st 10]) + (typed-with-handler StateHandler + ([State + (get (k) (resume k st)) + (put (k v) (set! st v) (resume k (void)))]) + (State put (+ (State get) 5)) + (State get))) + 15) + +(test "typed-with-handler/missing effect errors" + (guard (exn [#t (condition-message exn)]) + (define-effect-signature TwoEffects + handles: (State Reader) + returns: any) + (typed-with-handler TwoEffects + ([State + (get (k) (resume k 0))]) + 'ok)) + "handler missing declared effects") + +(test "typed-with-handler/non-sig errors" + (guard (exn [#t (condition-message exn)]) + (typed-with-handler 'not-a-sig + ([State (get (k) (resume k 0))]) + 'ok)) + "not an effect signature") + +;; ========== Multiple effects ========== + +(defeffect Log (emit msg)) + +(define-effect-signature StateLogHandler + handles: (State Log) + returns: any) + +(test "typed-with-handler/two effects" + (let ([st 0] [log '()]) + (typed-with-handler StateLogHandler + ([State + (get (k) (resume k st)) + (put (k v) (set! st v) (resume k (void)))] + [Log + (emit (k msg) (set! log (append log (list msg))) (resume k (void)))]) + (State put 99) + (Log emit "done") + (list (State get) log))) + '(99 ("done"))) + +;; ========== Signature with no effects ========== + +(define-effect-signature PureHandler + handles: () + returns: any) + +(test "typed-with-handler/pure" + (typed-with-handler PureHandler + () + (+ 1 2)) + 3) + +(printf "~%Results: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-gadt.ss @@ -0,0 +1,180 @@ +#!chezscheme +;;; Tests for (std typed gadt) — Generalized Algebraic Data Types + +(import (chezscheme) (std typed gadt)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- Phase 2c: GADTs ---~%~%") + +;; ========== GADT: Expr ========== + +(define-gadt Expr + (Lit val) + (Add a b) + (IsZ e) + (If c t f)) + +;; Constructor tests +(test "gadt?/Lit" + (gadt? (Lit 42)) + #t) + +(test "gadt?/non-gadt" + (gadt? 42) + #f) + +(test "gadt?/vector-not-gadt" + (gadt? (vector 1 2 3)) + #f) + +(test "Expr? predicate" + (Expr? (Lit 10)) + #t) + +(test "Expr? wrong type" + (Expr? (vector 'gadt-box 'Other 'Lit 10)) + #f) + +(test "gadt-tag/Lit" + (gadt-tag (Lit 99)) + 'Lit) + +(test "gadt-tag/Add" + (gadt-tag (Add (Lit 1) (Lit 2))) + 'Add) + +(test "gadt-constructor alias" + (gadt-constructor (Lit 5)) + 'Lit) + +(test "gadt-fields/Lit" + (gadt-fields (Lit 42)) + '(42)) + +(test "gadt-fields/Add" + (let ([e (Add (Lit 1) (Lit 2))]) + (length (gadt-fields e))) + 2) + +(test "gadt-fields/If 3 args" + (length (gadt-fields (If (IsZ (Lit 0)) (Lit 1) (Lit 2)))) + 3) + +;; ========== Pattern matching ========== + +(define (eval-expr e) + (gadt-match e + [(Lit v) v] + [(Add a b) (+ (eval-expr a) (eval-expr b))] + [(IsZ x) (= (eval-expr x) 0)] + [(If c t f) (if (eval-expr c) (eval-expr t) (eval-expr f))])) + +(test "gadt-match/Lit" + (eval-expr (Lit 10)) + 10) + +(test "gadt-match/Add" + (eval-expr (Add (Lit 3) (Lit 4))) + 7) + +(test "gadt-match/IsZ true" + (eval-expr (IsZ (Lit 0))) + #t) + +(test "gadt-match/IsZ false"