Phase 1: Algebraic effect system (Steps 9-10)
ober
8d0b26c881afc623314c4baa20dbd24c14bfd231
--- a/Makefile +++ b/Makefile @@ -82,6 +82,7 @@ test-features: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-task.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-cache.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-effect.ss test-all: test test-features test-wrappers new file mode 100644 --- /dev/null +++ b/lib/std/effect.sls @@ -0,0 +1,171 @@ +#!chezscheme +;;; (std effect) — Algebraic effects using one-shot continuations +;;; +;;; API: +;;; (defeffect Name (op1 arg ...) ...) — define an effect with operations +;;; (perform (Name op-name arg ...)) — perform an effect operation +;;; (with-handler ([Name (op (k arg ...) body ...) ...] ...) body ...) +;;; (resume k val) — resume a captured continuation +;;; +;;; Implementation uses call/1cc (one-shot continuations) for efficiency. +;;; Effect dispatch is O(1) via eq-hashtable on effect descriptors. + +(library (std effect) + (export + defeffect + with-handler + perform + resume + effect-not-handled? + effect-perform) + + (import (chezscheme)) + + ;; ========== Effect descriptor ========== + + (define-record-type effect-descriptor + (fields (immutable name)) + (sealed #t)) + + ;; ========== Handler stack ========== + ;; Thread-local stack of frames. + ;; Each frame: eq-hashtable mapping effect-descriptor -> ((op-sym . proc) ...) + ;; proc :: (k arg ...) -> any, k = one-shot continuation + + (define *effect-handlers* (make-thread-parameter '())) + + (define (find-handler descriptor op-sym) + (let loop ([stack (*effect-handlers*)]) + (cond + [(null? stack) #f] + [else + (let ([ops (hashtable-ref (car stack) descriptor #f)]) + (if ops + (let ([entry (assq op-sym ops)]) + (if entry (cdr entry) (loop (cdr stack)))) + (loop (cdr stack))))]))) + + ;; ========== Unhandled effect condition ========== + + (define-condition-type &effect-not-handled &serious + make-effect-not-handled effect-not-handled? + (descriptor effect-not-handled-descriptor) + (operation effect-not-handled-operation)) + + ;; ========== Runtime: perform an effect ========== + + (define (effect-perform descriptor op-sym args) + (let ([handler (find-handler descriptor op-sym)]) + (if handler + (call/1cc + (lambda (k) + (apply handler k args))) + (raise + (condition + (make-message-condition + (string-append "effect not handled: " + (symbol->string (effect-descriptor-name descriptor)) + "/" + (symbol->string op-sym))) + (make-effect-not-handled descriptor op-sym) + (make-irritants-condition (cons op-sym args))))))) + + ;; ========== resume ========== + + (define (resume k val) (k val)) + + ;; ========== perform (alias for user convenience) ========== + ;; (perform (EffectName op arg ...)) expands via defeffect. + ;; This is just a syntax marker — actual expansion is in defeffect. + (define-syntax perform + (lambda (stx) + (syntax-case stx () + [(_ expr) #'expr]))) + + ;; ========== with-handler (runtime helper) ========== + + (define (run-with-handler frame thunk) + (parameterize ([*effect-handlers* (cons frame (*effect-handlers*))]) + (thunk))) + + ;; ========== defeffect macro ========== + ;; + ;; (defeffect Async + ;; (await promise) + ;; (spawn thunk)) + ;; + ;; Generates: + ;; Async::descriptor — unique effect-descriptor instance + ;; (Async await arg ...) — performs the Async/await operation + + (define-syntax defeffect + (lambda (stx) + (syntax-case stx () + [(_ eff-name (op-sym op-arg ...) ...) + (identifier? #'eff-name) + (with-syntax ([desc-id + (datum->syntax #'eff-name + (string->symbol + (string-append + (symbol->string (syntax->datum #'eff-name)) + "::descriptor")))]) + #'(begin + (define desc-id + (make-effect-descriptor 'eff-name)) + (define-syntax eff-name + (lambda (inner) + (syntax-case inner () + [(_ op arg (... ...)) + #`(effect-perform desc-id 'op (list arg (... ...)))])))))]))) + + ;; ========== with-handler macro ========== + ;; + ;; (with-handler + ;; ([Async + ;; (await (k promise) expr ...) + ;; (spawn (k thunk) expr ...)] + ;; [State + ;; (get (k) expr ...) + ;; (put (k v) expr ...)]) + ;; body ...) + ;; + ;; Handler proc receives k (continuation) as first arg, then operation args. + + (define-syntax with-handler + (lambda (stx) + (define (effect-desc-id eff-name-stx) + (datum->syntax eff-name-stx + (string->symbol + (string-append + (symbol->string (syntax->datum eff-name-stx)) + "::descriptor")))) + + (define (build-op-pair op-clause) + ;; op-clause: (op-sym (k arg ...) body ...) + ;; produces: (cons 'op-sym (lambda (k arg ...) body ...)) + (syntax-case op-clause () + [(op-sym (k arg ...) body ...) + #'(cons 'op-sym (lambda (k arg ...) body ...))])) + + (define (build-effect-entry eff-clause) + ;; eff-clause: [eff-name op-clause ...] + ;; produces: (list desc-id (cons 'op ...) ...) + (syntax-case eff-clause () + [(eff-name op-clause ...) + (with-syntax ([desc-id (effect-desc-id #'eff-name)] + [(op-pair ...) (map build-op-pair + (syntax->list #'(op-clause ...)))]) + #'(list desc-id op-pair ...))])) + + (syntax-case stx () + [(_ (eff-clause ...) body ...) + (with-syntax ([(entry ...) (map build-effect-entry + (syntax->list #'(eff-clause ...)))] + [frame-id (datum->syntax #'with-handler (gensym "hframe"))]) + #'(let ([frame-id (make-eq-hashtable)]) + (let ([e entry]) + (hashtable-set! frame-id (car e) (cdr e))) + ... + (run-with-handler frame-id (lambda () body ...))))]))) + + ) ;; end library --- a/lib/std/typed.sls +++ b/lib/std/typed.sls @@ -18,7 +18,10 @@ register-type-predicate! type-predicate ;; Phase 3: op specialization - with-fixnum-ops with-flonum-ops) + with-fixnum-ops with-flonum-ops + ;; Phase 4 (Step 10): effect type annotations + define/te lambda/te + effect-type? make-effect-type effect-type-effect effect-type-result) (import (chezscheme)) ;; ========== Configuration ========== @@ -319,4 +322,96 @@ (syntax->list #'(body ...)))]) (datum->syntax #'kw `(begin ,@transformed)))]))) + ;; ========== Step 10: Effect Type Annotations ========== + ;; + ;; (Effect EffectName ReturnType) — type of a computation that performs EffectName + ;; and returns a value of ReturnType. + ;; + ;; (define/te (name [arg : type] ...) : (Effect E R) body ...) + ;; Like define/t but allows (Effect E R) return type annotation. + ;; In debug mode: checks non-effect argument types; the effect annotation + ;; is informational (full effect tracking requires compile-time analysis). + ;; + ;; (lambda/te ([arg : type] ...) : (Effect E R) body ...) + + (define-record-type effect-type + (fields (immutable effect) (immutable result)) + (sealed #t)) + + ;; We handle (Effect E R) syntactically: the result type R is what + ;; gets checked at runtime; the E is recorded for tooling. + + ;; define/te: define with typed effect return annotation + ;; (define/te (name [arg : type] ...) : (Effect EffName RetType) body ...) + (define-syntax define/te + (lambda (stx) + (define (parse-typed-args args) + (let loop ([rest (syntax->list args)] [result '()]) + (if (null? rest) + (reverse result) + (let ([item (car rest)]) + (syntax-case item () + [(arg-name sep type-name) + (eq? (syntax->datum #'sep) ':) + (loop (cdr rest) + (cons (list #'arg-name #'type-name) result))] + [arg-name + (identifier? #'arg-name) + (loop (cdr rest) + (cons (list #'arg-name (datum->syntax #'arg-name 'any)) result))]))))) + (syntax-case stx () + ;; With (Effect E R) return type + [(k (name typed-arg ...) colon (Effect eff-name ret-type) body ...) + (eq? (syntax->datum #'colon) ':) + (let ([parsed (parse-typed-args #'(typed-arg ...))]) + (with-syntax ([(arg ...) (map car parsed)] + [((aname atype) ...) parsed]) + ;; Only check arg types in debug mode; effect annotation is informational + #'(define (name arg ...) + (check-type! 'name 'aname arg 'atype) ... + (let ([result (begin body ...)]) + ;; Check return value against ret-type (not the Effect wrapper) + (check-return-type! 'name result 'ret-type) + result))))] + ;; Fallback: no effect annotation — delegate to define/t behavior + [(k (name typed-arg ...) colon ret-type body ...) + (eq? (syntax->datum #'colon) ':) + #'(define/t (name typed-arg ...) : ret-type body ...)] + [(k (name typed-arg ...) body ...) + #'(define/t (name typed-arg ...) body ...)]))) + + ;; lambda/te: lambda with effect return annotation + (define-syntax lambda/te + (lambda (stx) + (define (parse-typed-args args) + (let loop ([rest (syntax->list args)] [result '()]) + (if (null? rest) + (reverse result) + (let ([item (car rest)]) + (syntax-case item () + [(arg-name sep type-name) + (eq? (syntax->datum #'sep) ':) + (loop (cdr rest) + (cons (list #'arg-name #'type-name) result))] + [arg-name + (identifier? #'arg-name) + (loop (cdr rest) + (cons (list #'arg-name (datum->syntax #'arg-name 'any)) result))]))))) + (syntax-case stx () + [(k (typed-arg ...) colon (Effect eff-name ret-type) body ...) + (eq? (syntax->datum #'colon) ':) + (let ([parsed (parse-typed-args #'(typed-arg ...))]) + (with-syntax ([(arg ...) (map car parsed)] + [((aname atype) ...) parsed]) + #'(lambda (arg ...) + (check-type! 'lambda 'aname arg 'atype) ... + (let ([result (begin body ...)]) + (check-return-type! 'lambda result 'ret-type) + result))))] + [(k (typed-arg ...) colon ret-type body ...) + (eq? (syntax->datum #'colon) ':) + #'(lambda/t (typed-arg ...) : ret-type body ...)] + [(k (typed-arg ...) body ...) + #'(lambda/t (typed-arg ...) body ...)]))) + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-effect.ss @@ -0,0 +1,175 @@ +#!chezscheme +;;; Tests for (std effect) — Algebraic effect system + +(import (chezscheme) (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 "--- (std effect) tests ---~%") + +;;;; Effect 1: State + +(defeffect State + (get) + (put val)) + +(test "state/get basic" + (let ([st 10]) + (with-handler ([State + (get (k) (resume k st)) + (put (k v) (set! st v) (resume k (void)))]) + (State get))) + 10) + +(test "state/put+get" + (let ([st 0]) + (with-handler ([State + (get (k) (resume k st)) + (put (k v) (set! st v) (resume k (void)))]) + (State put 42) + (State get))) + 42) + +(test "state/multiple ops in sequence" + (let ([st 1]) + (with-handler ([State + (get (k) (resume k st)) + (put (k v) (set! st v) (resume k (void)))]) + (State put (+ (State get) 10)) + (State put (+ (State get) 5)) + (State get))) + 16) + +;;;; Effect 2: Logging (append-only) + +(defeffect Log + (emit msg)) + +(test "log/emit" + (let ([log '()]) + (with-handler ([Log + (emit (k msg) + (set! log (append log (list msg))) + (resume k (void)))]) + (Log emit "hello") + (Log emit "world") + log)) + '("hello" "world")) + +;;;; Effect 3: Abort (non-resuming) + +(defeffect Abort + (abort val)) + +(test "abort/basic" + (call-with-current-continuation + (lambda (escape) + (with-handler ([Abort + (abort (k v) (escape v))]) + (Abort abort 'done) + 'never-reached))) + 'done) + +(test "abort/skips remaining" + (let ([counter 0]) + (call-with-current-continuation + (lambda (escape) + (with-handler ([Abort + (abort (k v) (escape counter))]) + (set! counter (+ counter 1)) + (Abort abort 'stop) + (set! counter (+ counter 1))))) ;; this line not reached + counter) + 1) + +;;;; Effect 4: Choose (nondeterminism stub — single-shot returns first choice) + +(defeffect Choose + (flip)) + +(test "choose/true" + (with-handler ([Choose (flip (k) (resume k #t))]) + (Choose flip)) + #t) + +(test "choose/false" + (with-handler ([Choose (flip (k) (resume k #f))]) + (Choose flip)) + #f) + +;;;; Effect 5: Unhandled effect raises condition + +(defeffect Unhandled + (boom)) + +(test "unhandled/raises condition" + (guard (exn [(effect-not-handled? exn) 'caught]) + (Unhandled boom) + 'missed) + 'caught) + +;;;; Effect 6: Nested handlers — inner wins + +(defeffect Counter + (tick)) + +(test "nested/inner wins" + (with-handler ([Counter (tick (k) (resume k 1))]) + (with-handler ([Counter (tick (k) (resume k 2))]) + (Counter tick))) + 2) + +(test "nested/outer fallback after inner exits" + (with-handler ([Counter (tick (k) (resume k 100))]) + (let ([inner + (with-handler ([Counter (tick (k) (resume k 200))]) + (Counter tick))]) + ;; after inner handler exits, outer handles + (list inner (Counter tick)))) + '(200 100)) + +;;;; Effect 7: Combining multiple effects + +(defeffect Yield + (yield val)) + +(test "two effects together" + (let ([log '()] [st 0]) + (with-handler ([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 5) + (Log emit "a") + (State put (+ (State get) 3)) + (Log emit "b") + (list (State get) log))) + '(8 ("a" "b"))) + +;;;; Effect 8: perform macro (alias) + +(test "perform alias" + (let ([st 77]) + (with-handler ([State + (get (k) (resume k st)) + (put (k v) (set! st v) (resume k (void)))]) + (perform (State get)))) + 77) + +(printf "~%~a tests: ~a passed, ~a failed~%" + (+ pass fail) pass fail) +(when (> fail 0) (exit 1))