Phase 4a complete: Core Runtime (6 libraries, 165 tests passing)
ober
8da1a94850b89be3da866507241ad5d1a0f75150
--- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-https/src:$(CHEZ_EXT_DIR)/chez-ssl/src:$ # Shared object paths for FFI-based chez-* libraries CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_DIR)/chez-pcre2:$(CHEZ_EXT_DIR)/chez-leveldb:$(CHEZ_EXT_DIR)/chez-epoll:$(CHEZ_EXT_DIR)/chez-inotify:$(CHEZ_EXT_DIR)/chez-crypto:$(CHEZ_EXT_DIR)/chez-sqlite:$(CHEZ_EXT_DIR)/chez-postgresql -.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers clean +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a clean test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded @@ -131,6 +131,15 @@ test-phase3: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-wasm-codegen.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-wasm-runtime.ss +test-phase4a: + @echo "--- Phase 4a: Core Runtime tests ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-effect-deep.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-engine-pool.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-transducer.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-type-env.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-type-infer.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-error-advice.ss + test-all: test test-features test-wrappers clean: new file mode 100644 --- /dev/null +++ b/lib/std/actor/engine.sls @@ -0,0 +1,231 @@ +#!chezscheme +;;; (std actor engine) — Engine-based preemptive actor scheduling +;;; +;;; Chez Scheme's engine API provides preemptible computations via +;;; "fuel" (instruction quanta). This library builds an actor pool +;;; where each actor is run inside an engine so that long-running +;;; behaviors are automatically time-sliced. +;;; +;;; API: +;;; (make-engine-pool #:workers n #:fuel f) -> engine-pool +;;; (engine-pool? x) +;;; (spawn-engine-actor pool behavior) -> actor-ref +;;; (engine-pool-submit! pool thunk) +;;; (engine-pool-stop! pool) +;;; (engine-pool-worker-count pool) +;;; (default-fuel) -> 10000 +;;; +;;; How it works: +;;; Each worker OS thread runs a tight loop that dequeues thunks and +;;; wraps them in Chez engines. If a thunk's engine runs out of fuel +;;; (the computation is still in progress) the remaining engine is +;;; re-queued so another worker can eventually run it. When the +;;; engine completes the result is discarded (fire-and-forget +;;; semantics, matching the actor model). + +(library (std actor engine) + (export + make-engine-pool + engine-pool? + spawn-engine-actor + engine-pool-submit! + engine-pool-stop! + engine-pool-worker-count + default-fuel) + + (import (chezscheme) (std actor core)) + + ;; -------- Default fuel quanta -------- + + (define (default-fuel) 10000) + + ;; -------- Shared task queue -------- + ;; A simple mutex-protected FIFO of thunks / pending engines. + ;; Each item is either: + ;; (cons 'thunk thunk) — not yet started, wrap in make-engine + ;; (cons 'engine engine-fn) — partially run, resume with more fuel + + (define-record-type eng-task-queue + (fields + (immutable mutex) + (immutable not-empty) ;; condition variable + (mutable head) ;; list: items ready to dequeue + (mutable tail)) ;; list: newly enqueued items (reversed) + (protocol + (lambda (new) + (lambda () + (new (make-mutex) + (make-condition) + '() + '())))) + (sealed #t)) + + (define (tq-enqueue! tq item) + (with-mutex (eng-task-queue-mutex tq) + (eng-task-queue-tail-set! tq (cons item (eng-task-queue-tail tq))) + (condition-signal (eng-task-queue-not-empty tq)))) + + ;; Blocking dequeue. Returns an item, or #f when the pool is stopping. + (define (tq-dequeue! tq running-thunk) + (mutex-acquire (eng-task-queue-mutex tq)) + (let loop () + (cond + ;; Head has items — take from front + [(pair? (eng-task-queue-head tq)) + (let ([item (car (eng-task-queue-head tq))]) + (eng-task-queue-head-set! tq (cdr (eng-task-queue-head tq))) + (mutex-release (eng-task-queue-mutex tq)) + item)] + ;; Promote tail into head + [(pair? (eng-task-queue-tail tq)) + (eng-task-queue-head-set! tq (reverse (eng-task-queue-tail tq))) + (eng-task-queue-tail-set! tq '()) + (loop)] + ;; Empty — wait if still running + [(running-thunk) + (condition-wait (eng-task-queue-not-empty tq) + (eng-task-queue-mutex tq)) + (loop)] + ;; Stopping — release and signal shutdown + [else + (mutex-release (eng-task-queue-mutex tq)) + #f]))) + + ;; -------- Engine pool record -------- + ;; Use a distinct record name (eng-pool-rec) so we can provide a + ;; user-facing make-engine-pool procedure with keyword parsing. + + (define-record-type eng-pool-rec + (fields + (immutable queue) ;; eng-task-queue + (immutable fuel) ;; integer: ticks per engine slice + (immutable nworkers) ;; integer: number of OS threads + (mutable running?)) ;; boolean + (protocol + (lambda (new) + (lambda (nworkers fuel) + (new (make-eng-task-queue) fuel nworkers #f)))) + (sealed #t)) + + (define engine-pool? eng-pool-rec?) + + ;; -------- Worker loop -------- + ;; + ;; NOTE: In Chez Scheme 10.x the engine API uses INVERTED semantics + ;; compared to the traditional (Dybvig) documentation: + ;; + ;; expire-proc — called when the computation FINISHES within the fuel + ;; budget: (expire-proc remaining-fuel result) + ;; complete-proc — called when the computation is PREEMPTED (fuel + ;; exhausted): (complete-proc new-engine) + ;; + ;; We rename the parameters accordingly: done-proc / preempt-proc. + + (define (worker-loop pool) + (let ([q (eng-pool-rec-queue pool)] + [fuel (eng-pool-rec-fuel pool)]) + (let loop () + (let ([item (tq-dequeue! q (lambda () (eng-pool-rec-running? pool)))]) + (when item + ;; Build or retrieve the engine + (let ([eng (case (car item) + [(thunk) (make-engine (cdr item))] + [(engine) (cdr item)] + [else + (error 'engine-pool-worker + "unknown task type" (car item))])]) + ;; Run the engine for one fuel slice. + (eng fuel + ;; done-proc (called "expire" in Chez): computation finished + ;; (remaining-fuel result) — result is discarded (fire-and-forget) + (lambda (remaining result) (void)) + ;; preempt-proc (called "complete" in Chez): fuel exhausted + ;; (new-engine) — re-enqueue the continuation + (lambda (new-engine) + (tq-enqueue! q (cons 'engine new-engine))))) + (loop)))))) + + ;; -------- Public API -------- + + ;; Keyword predicate helpers. + ;; In Chez Scheme, the #:foo syntax at a call site evaluates the symbol + ;; as a variable, so callers must quote keyword symbols: '#:workers. + ;; We compare by symbol name string (stripping a leading "#:" if present). + (define (kw=? sym name) + (and (symbol? sym) + (let ([s (symbol->string sym)]) + (or (string=? s name) + ;; Accept symbol with literal "#:" prefix in case the reader + ;; is configured to preserve it (some Chez versions / modes). + (and (fx>= (string-length s) 2) + (char=? (string-ref s 0) #\#) + (char=? (string-ref s 1) #\:) + (string=? (substring s 2 (string-length s)) name)))))) + + ;; (make-engine-pool '#:workers n '#:fuel f) + ;; OR (make-engine-pool) for defaults (4 workers, default-fuel ticks). + ;; OR (make-engine-pool n) for n workers with default fuel. + ;; OR (make-engine-pool n f) for n workers with f fuel. + (define (make-engine-pool . args) + (define (start! workers fuel) + (let ([pool (make-eng-pool-rec workers fuel)]) + (eng-pool-rec-running?-set! pool #t) + (do ([i 0 (fx+ i 1)]) + ((fx= i workers)) + (fork-thread (lambda () (worker-loop pool)))) + pool)) + (cond + ;; No args — defaults + [(null? args) + (start! 4 (default-fuel))] + ;; First arg is a number — positional: (workers) or (workers fuel) + [(and (number? (car args)) (null? (cdr args))) + (start! (car args) (default-fuel))] + [(and (number? (car args)) (pair? (cdr args)) (number? (cadr args)) + (null? (cddr args))) + (start! (car args) (cadr args))] + ;; Keyword-style: '#:workers n '#:fuel f (args are quoted symbols) + [else + (let parse ([rest args] [workers 4] [fuel (default-fuel)]) + (cond + [(null? rest) (start! workers fuel)] + [(and (kw=? (car rest) "workers") (pair? (cdr rest))) + (parse (cddr rest) (cadr rest) fuel)] + [(and (kw=? (car rest) "fuel") (pair? (cdr rest))) + (parse (cddr rest) workers (cadr rest))] + [else + (error 'make-engine-pool + "unexpected argument (use '#:workers n or '#:fuel f)" + (car rest))]))])) + + (define (engine-pool-submit! pool thunk) + (unless (eng-pool-rec-running? pool) + (error 'engine-pool-submit! "pool has been stopped" pool)) + (tq-enqueue! (eng-pool-rec-queue pool) (cons 'thunk thunk))) + + (define (engine-pool-stop! pool) + (eng-pool-rec-running?-set! pool #f) + ;; Broadcast to wake all sleeping workers so they exit their loops + (with-mutex (eng-task-queue-mutex (eng-pool-rec-queue pool)) + (condition-broadcast + (eng-task-queue-not-empty (eng-pool-rec-queue pool))))) + + (define (engine-pool-worker-count pool) + (eng-pool-rec-nworkers pool)) + + ;; Spawn an actor that runs preemptively inside the engine pool. + ;; + ;; The pool is installed as the global actor scheduler so that all + ;; subsequent scheduling decisions for this actor land in the pool's + ;; engine queue, giving preemptive time-slicing. + ;; + ;; Callers that want multiple pools should set the scheduler themselves + ;; before spawning; this convenience wrapper sets it once and leaves it. + (define (spawn-engine-actor pool behavior) + ;; Build a submit procedure matching set-actor-scheduler!'s contract: + ;; it receives a zero-argument thunk and submits it to the pool. + (set-actor-scheduler! + (lambda (thunk) (engine-pool-submit! pool thunk))) + (spawn-actor behavior)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/effect/deep.sls @@ -0,0 +1,108 @@ +#!chezscheme +;;; (std effect deep) — Deep algebraic effect handlers +;;; +;;; Deep handlers re-install themselves after each resume, so the handler +;;; persists for the entire scope of the computation body. By contrast, +;;; the shallow handlers in (std effect) are consumed on each resume. +;;; +;;; API: +;;; (with-deep-handler +;;; ([EffectName (op-name (k arg ...) body ...) ...] ...) +;;; body ...) +;;; +;;; (resume/deep k val handler-frame) +;;; Internal helper that resumes k while re-installing the handler frame. +;;; +;;; The macro captures the handler frame at the point of the +;;; with-deep-handler call and wraps every user-supplied k with a +;;; closure that re-pushes that frame before resuming, so any further +;;; effect performs inside the resumed computation are seen by the same +;;; handler. + +(library (std effect deep) + (export + with-deep-handler + resume/deep) + + (import (chezscheme) (std effect)) + + ;; -------- resume/deep -------- + ;; + ;; Re-installs frame onto *effect-handlers* before resuming k. + ;; This ensures that any effect performed during the resumed + ;; computation is caught by the same handler that originally + ;; intercepted the operation. + + (define (resume/deep k val frame) + (run-with-handler frame (lambda () (k val)))) + + ;; -------- with-deep-handler macro -------- + ;; + ;; (with-deep-handler + ;; ([Async + ;; (await (k promise) expr ...) + ;; (spawn (k thunk) expr ...)] + ;; [State + ;; (get (k) expr ...) + ;; (put (k v) expr ...)]) + ;; body ...) + ;; + ;; Each k received in a handler clause is automatically wrapped so + ;; that calling (k val) is equivalent to (resume/deep k val frame). + ;; The original k is bound to k/raw if you need the raw one-shot + ;; continuation, but in typical usage you just use k. + + (define-syntax with-deep-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")))) + + ;; Rewrite an op-clause, wrapping k with a deep-resume closure. + ;; Input: (op-sym (k arg ...) body ...) + ;; Output: (op-sym (k/raw arg ...) body ...[k->resume/deep k/raw]) + ;; We synthesize a new k name and rebind it. + (define (build-deep-op-pair op-clause frame-id-stx) + (syntax-case op-clause () + [(op-sym (k arg ...) body ...) + ;; k-raw is used to call the original one-shot continuation + ;; after wrapping with the frame. + (with-syntax ([k-raw (datum->syntax #'k (gensym "k-raw"))] + [frame-id frame-id-stx]) + #'(cons 'op-sym + (lambda (k-raw arg ...) + ;; Rebind k to the deep-resuming wrapper. + (let ([k (lambda (v) (resume/deep k-raw v frame-id))]) + body ...))))])) + + (define (build-deep-effect-entry eff-clause frame-id-stx) + (syntax-case eff-clause () + [(eff-name op-clause ...) + (with-syntax ([desc-id (effect-desc-id #'eff-name)] + [(op-pair ...) + (map (lambda (c) (build-deep-op-pair c frame-id-stx)) + (syntax->list #'(op-clause ...)))]) + #'(list desc-id op-pair ...))])) + + (syntax-case stx () + [(_ (eff-clause ...) body ...) + ;; We need frame-id to be bound before the entries are built + ;; (it is referenced inside the lambda wrappers), so we use + ;; letrec to allow forward reference: frame is set! once built. + (let ([frame-id (datum->syntax #'with-deep-handler (gensym "dframe"))]) + (with-syntax ([frame-id frame-id] + [(entry ...) + (map (lambda (c) (build-deep-effect-entry c frame-id)) + (syntax->list #'(eff-clause ...)))]) + #'(let ([frame-id #f]) + (let ([tbl (make-eq-hashtable)]) + (let ([e entry]) + (hashtable-set! tbl (car e) (cdr e))) + ... + (set! frame-id tbl) + (run-with-handler frame-id (lambda () body ...))))))]))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/error-advice.sls @@ -0,0 +1,245 @@ +#!chezscheme +;;; (std error-advice) — Error messages with actionable fix suggestions +;;; +;;; Catches common Chez Scheme errors and augments them with plain-English +;;; fix suggestions. Built on top of Chez's condition system. +;;; +;;; API: +;;; (error-with-advice msg irritant ...) — like error but advice-checked +;;; (advise-error condition) — return fix string or #f +;;; (define-error-advice pattern fix-tmpl) — register advice rule +;;; (*error-advice-enabled* #t/#f) — parameter (default #t) +;;; (with-error-advice body ...) — install advisor for body +;;; (install-error-advisor!) — install globally +;;; common-error-fixes — built-in alist of (pattern . fix) +;;; (format-error-with-fix condition) — format condition + fix suggestion + +(library (std error-advice) + (export + error-with-advice + advise-error + define-error-advice + *error-advice-enabled* + with-error-advice + install-error-advisor! + common-error-fixes + format-error-with-fix) + + (import (chezscheme) (std pregexp)) + + ;; ========== Configuration ========== + + (define *error-advice-enabled* + (make-parameter #t + (lambda (v) + (unless (boolean? v) + (error '*error-advice-enabled* "must be boolean" v)) + v))) + + ;; ========== Advice rule storage ========== + ;; + ;; Each rule is a pair (compiled-regexp . fix-template-string). + ;; Rules are tried in order; first match wins. + + (define *advice-rules* '()) + + ;; Register a new rule. pattern is a pregexp string; fix-template is a + ;; plain string (may include ~a / ~s placeholders in future). + (define (register-advice! pattern fix-template) + (let ([rx (pregexp pattern)]) + (set! *advice-rules* + (append *advice-rules* (list (cons rx fix-template)))))) + + ;; ========== common-error-fixes ========== + ;; + ;; Built-in advice for the most common Chez Scheme runtime errors. + ;; Exported as a plain alist for user inspection. + + (define common-error-fixes + '(;; Arity errors + ("wrong number of arguments" . + "Check the function's signature. Use (procedure-arity f) to inspect expected argument counts. Ensure you are not passing too few or too many arguments.") + + ;; Unbound variable + ("(?i:unbound variable|variable .* is not bound|undefined)" . + "The variable is not in scope. Check that it is imported, defined before use, and spelled correctly. Common typos: forgot to (import ...) or misspelled the library name.") + + ;; car/cdr on non-pair + ("(?i:car.*not a pair|\\(\\) is not a pair|cdr.*not a pair)" . + "You are calling car or cdr on an empty list or a non-pair value. Check for null? first, or verify the list is non-empty before destructuring.") + + ;; Arithmetic type error + ("(?i:not a (real )?number|\\+ .* not a number|\\* .* not a number|\\- .* not a number)" . + "A non-numeric value was passed to an arithmetic operation. Did you use string-append instead of + for strings? Or mix up a string/symbol with a number?") + + ;; string-ref out of range + ("(?i:string-ref.*out of range|index .* out of range.*string)" . + "The string index is out of bounds. Check (string-length s) before calling (string-ref s i). Remember indices are 0-based and the valid range is 0 .. (string-length s)-1.") + + ;; vector-ref out of range + ("(?i:vector-ref.*out of range|index .* out of range.*vector)" . + "The vector index is out of bounds. Check (vector-length v) before indexing. Valid indices are 0 .. (vector-length v)-1.") + + ;; Applying non-procedure + ("(?i:attempt to apply.*non-procedure|call of non-procedure|not a procedure)" . + "The value you are calling is not a procedure. Double-check that the name is bound to a function, not a variable or syntax form. If using higher-order functions, ensure the callback is actually a procedure.") + + ;; Assertion violation + ("(?i:assertion violation)" . + "A precondition was violated. Read the error message for which invariant failed, then check the inputs to the function. This often means a value is outside the expected range or has the wrong type.") + + ;; Division by zero + ("(?i:division by zero|divide.*by zero|zero divisor)" . + "Guard numeric division with (if (zero? denominator) fallback (/ numerator denominator)), or use (and (not (zero? x)) (/ ... x)).") + + ;; Contract violation + ("(?i:contract.*violation|violated contract)" . + "A contract or guard condition failed. Check the function's expected argument types and any precondition guards.") + + ;; I/O errors + ("(?i:no such file|file not found|cannot open)" . + "The file does not exist or is not accessible. Check the path, ensure the working directory is correct, and verify file permissions.") + + ;; Stack overflow / max recursion + ("(?i:stack overflow|maximum recursion|too many nested calls)" . + "Infinite or very deep recursion detected. Ensure the recursive call has a correct base case. Consider converting to a tail-recursive or iterative form.") + + ;; Type errors (various) + ("(?i:expected.*but got|type mismatch|wrong type)" . + "A value of the wrong type was passed. Check the expected type in the function's documentation or source, and add explicit type conversion if needed.") + + ;; Port errors + ("(?i:port is closed|port.*not open|closed port)" . + "The port has been closed before reading/writing was complete. Use call-with-port or ensure the port is open for the entire duration it is needed.") + + ;; Continuation/control errors + ("(?i:continuation.*cannot be used|escape.*procedure)" . + "A one-shot continuation or escape continuation was invoked outside its dynamic extent. Use call/cc carefully and avoid storing continuations beyond their scope.") + + ;; Hashtable errors + ("(?i:hashtable.*not a hashtable|hash.*not found)" . + "The value is not a hashtable, or you are using the wrong lookup procedure. Use (hashtable-ref ht key default) and ensure ht is created with make-equal-hashtable or similar."))) + + ;; ========== Installation of built-in rules ========== + + (define (install-builtin-rules!) + (for-each + (lambda (pair) + (register-advice! (car pair) (cdr pair))) + common-error-fixes)) + + ;; ========== define-error-advice macro ========== + + (define-syntax define-error-advice + (syntax-rules () + [(_ pattern fix-template) + (register-advice! pattern fix-template)])) + + ;; ========== Extract error message string from condition ========== + + (define (condition->message-string exn) + (cond + [(message-condition? exn) (condition-message exn)] + [(condition? exn) + ;; Try to get a report string from Chez's condition reporter + (guard (inner [#t ""]) + (let-values ([(port get) (open-string-output-port)]) + (display-condition exn port) + (get)))] + [(string? exn) exn] + [else + (guard (inner [#t ""]) + (format "~a" exn))])) + + ;; ========== advise-error ========== + ;; + ;; Given a Chez condition object, returns the first matching fix string or #f. + + (define (advise-error exn) + (and (*error-advice-enabled*) + (let ([msg (condition->message-string exn)]) + (let loop ([rules *advice-rules*]) + (if (null? rules) + #f + (let ([rx (caar rules)] + [fix (cdar rules)]) + (if (pregexp-match rx msg) + fix + (loop (cdr rules))))))))) + + ;; ========== format-error-with-fix ========== + + (define (format-error-with-fix exn) + (let ([base-msg (condition->message-string exn)] + [fix (advise-error exn)]) + (if fix + (string-append base-msg "\n\n Suggestion: " fix) + base-msg))) + + ;; ========== error-with-advice ========== + ;; + ;; Like (error who msg irritant ...) but first checks for advice and + ;; prepends the suggestion to the message if one is found. + + (define (error-with-advice msg . irritants) + ;; Build a temporary condition to check if we have advice for this message + (let* ([test-condition + (condition + (make-message-condition msg) + (make-irritants-condition irritants))] + [fix (advise-error test-condition)] + [full-msg (if fix + (string-append msg "\n\n Suggestion: " fix) + msg)]) + (apply error full-msg irritants))) + + ;; ========== with-error-advice ========== + ;; + ;; Installs an exception handler for the dynamic extent of body that + ;; augments error displays with fix suggestions. Errors are re-raised + ;; after the suggestion is printed; non-continuable errors propagate. + + (define-syntax with-error-advice + (syntax-rules () + [(_ body ...) + (with-exception-handler + (lambda (exn) + (when (*error-advice-enabled*) + (let ([fix (advise-error exn)]) + (when fix + (display "\n Suggestion: " (current-error-port)) + (display fix (current-error-port)) + (newline (current-error-port))))) + ;; Re-raise so normal error handling still applies + (raise-continuable exn)) + (lambda () body ...))])) + + ;; ========== install-error-advisor! ========== + ;; + ;; Installs advice display as a persistent side-channel alongside Chez's + ;; normal condition handler. Uses `with-exception-handler` at the REPL + ;; interaction level. This is advisory only — normal Chez error handling + ;; continues unaffected. + + (define *advisor-installed* #f) + + (define (install-error-advisor!) + (unless *advisor-installed* + (set! *advisor-installed* #t) + ;; Wrap the current exception handler + (let ([prev (current-exception-state)]) + (current-exception-state + (lambda (exn) + ;; Show suggestion first (if any), then delegate to Chez handler + (when (*error-advice-enabled*) + (let ([fix (advise-error exn)]) + (when fix + (display "\n Suggestion: " (current-error-port)) + (display fix (current-error-port)) + (newline (current-error-port))))) + (prev exn)))))) + + ;; Install built-in rules on library load (must be after all definitions) + (install-builtin-rules!) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/transducer.sls @@ -0,0 +1,469 @@ +#!chezscheme +;;; (std transducer) — Composable, efficient data transformations +;;; +;;; A transducer is a function xf :: rf -> rf', where rf is a +;;; reducing function with three arities: +;;; +;;; (rf) — init: return initial accumulator +;;; (rf acc) — completion: flush / finalize +;;; (rf acc item) — step: fold one item into accumulator +;;; +;;; Transducers are composable via compose-transducers (left-to-right +;;; data flow, right-to-left function composition, matching Clojure +;;; convention). +;;; +;;; API: +;;; Core transducers: +;;; (mapping f) — transform each element +;;; (filtering pred) — keep elements satisfying pred +;;; (taking n) — keep first n elements +;;; (dropping n) — drop first n elements +;;; (flat-mapping f) — map then flatten one level +;;; (taking-while pred) — take while pred holds +;;; (dropping-while pred) — drop while pred holds +;;; (cat) — flatten one level of nesting +;;; (deduplicate) — remove consecutive duplicates +;;; (partitioning-by f) — group into runs with same (f item) +;;; (windowing n) — sliding windows of size n +;;; (indexing) — pair each element with its 0-based index +;;; (enumerating) — alias for indexing +;;; +;;; Composition: +;;; (compose-transducers xf1 xf2 ...) +;;; (xf-compose xf1 xf2 ...) — alias +;;; +;;; Reduction: +;;; (transduce xf rf init coll) +;;; +;;; Common reducing functions: +;;; (rf-cons) — build list (reversed during reduction, corrected at completion) +;;; (rf-append!) — build list efficiently with pair pointer +;;; (rf-count) — count elements +;;; (rf-sum) — sum numbers +;;; (rf-into-vector)— collect into a vector (via list then list->vector) +;;; +;;; High-level: +;;; (into dest xf coll) — transduce into dest (list, vector, or string) +;;; (sequence xf coll) — returns a list +;;; (eduction xf coll) — lazy composable sequence (represented as thunk) + +(library (std transducer) + (export + ;; Record predicate (make-transducer is intentionally not exported — + ;; transducers are just procedures; the record wraps them for identity.) + transducer? + + ;; Core transducers + mapping + filtering + taking + dropping + flat-mapping + taking-while + dropping-while + cat + deduplicate + partitioning-by + windowing + indexing + enumerating + + ;; Composition + compose-transducers + xf-compose + + ;; Reduction + transduce + + ;; Reducing functions + rf-cons + rf-append! + rf-count + rf-sum + rf-into-vector + + ;; High-level combinators + into + sequence + eduction) + + (import (chezscheme)) + + ;; ====================================================================== + ;; Transducer record + ;; A thin wrapper around a transformer function so transducer? works. + ;; ====================================================================== + + (define-record-type xducer + (fields (immutable fn)) + (sealed #t)) + + (define (transducer? x) (xducer? x)) + + ;; Internal: apply a transducer to a reducing function + (define (apply-xf xf rf) + ((xducer-fn xf) rf)) + + ;; ====================================================================== + ;; Reduced sentinel + ;; When a reducing function wants to short-circuit (e.g. taking), + ;; it wraps the accumulator in a reduced box. + ;; ====================================================================== + + (define-record-type reduced-box + (fields (immutable val)) + (sealed #t)) + + (define (reduced x) (make-reduced-box x)) + (define (reduced? x) (reduced-box? x)) + (define (unreduced x) + (if (reduced-box? x) (reduced-box-val x) x)) + + ;; Ensure result is unwrapped at the top level + (define (ensure-unreduced x) + (if (reduced-box? x) (reduced-box-val x) x)) + + ;; ====================================================================== + ;; Reducing function helpers + ;; ====================================================================== + + ;; A reducing function (rf) is a procedure of 0, 1, or 2 arguments. + ;; We represent it as a case-lambda. + + ;; Collect items into a list (constructed in reverse, reversed at completion) + (define (rf-cons) + (case-lambda + [() '()] + [(acc) (reverse acc)] + [(acc x) (cons x acc)])) + + ;; Efficient list builder using a mutable tail pointer + ;; Internal state: a pair (head-sentinel . last-pair) + (define (rf-append!) + (case-lambda + [() + ;; init: sentinel cons cell; tail points to it + (let ([sentinel (list 'sentinel)]) + (cons sentinel sentinel))] + [(state) + ;; completion: return everything after sentinel + (cdr (car state))] + [(state x) + ;; step: append x to the end via tail pointer + (let* ([new-pair (list x)] + [tail (cdr state)]) + (set-cdr! tail new-pair) + (cons (car state) new-pair))])) + + ;; Count items + (define (rf-count) + (case-lambda + [() 0] + [(acc) acc] + [(acc _) (+ acc 1)])) + + ;; Sum numbers + (define (rf-sum) + (case-lambda + [() 0] + [(acc) acc] + [(acc x) (+ acc x)])) + + ;; Collect into a vector (builds a list, converts at completion) + (define (rf-into-vector) + (let ([inner (rf-cons)]) + (case-lambda + [() (inner)] + [(acc) (list->vector (inner acc))] + [(acc x) (inner acc x)]))) + + ;; ====================================================================== + ;; Core transducers + ;; ====================================================================== + + ;; (mapping f) — apply f to each element before passing to rf + (define (mapping f) + (make-xducer + (lambda (rf) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) (rf acc (f x))])))) + + ;; (filtering pred) — only pass elements satisfying pred + (define (filtering pred) + (make-xducer + (lambda (rf) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) (if (pred x) (rf acc x) acc)])))) + + ;; (taking n) — pass first n elements, then short-circuit + (define (taking n) + (make-xducer + (lambda (rf) + (let ([remaining (box n)]) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) + (let ([r (unbox remaining)]) + (cond + [(fx<= r 0) (reduced acc)] + [else + (set-box! remaining (fx- r 1)) + (let ([result (rf acc x)]) + (if (fx<= (unbox remaining) 0) + (reduced (ensure-unreduced result)) + result))]))]))))) + + ;; (dropping n) — skip first n elements, then pass rest + (define (dropping n) + (make-xducer + (lambda (rf) + (let ([remaining (box n)]) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) + (let ([r (unbox remaining)]) + (if (fx> r 0) + (begin (set-box! remaining (fx- r 1)) acc) + (rf acc x)))]))))) + + ;; (flat-mapping f) — map f (which returns a collection) then flatten one level + (define (flat-mapping f) + (make-xducer + (lambda (rf) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) + ;; f returns a list; fold it into acc using rf + (let ([items (f x)]) + (let loop ([a acc] [lst items]) + (cond + [(null? lst) a] + [(reduced? a) a] + [else (loop (rf a (car lst)) (cdr lst))])))])))) + + ;; (taking-while pred) — pass elements while pred holds, then stop + (define (taking-while pred) + (make-xducer + (lambda (rf) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) + (if (pred x) + (rf acc x) + (reduced acc))])))) + + ;; (dropping-while pred) — drop elements while pred holds, then pass rest + (define (dropping-while pred) + (make-xducer + (lambda (rf) + (let ([dropping? (box #t)]) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) + (if (unbox dropping?) + (if (pred x) + acc ;; still dropping + (begin + (set-box! dropping? #f) + (rf acc x))) + (rf acc x))]))))) + + ;; (cat) — concatenate; each element is itself a collection, flatten one level + (define (cat) + (make-xducer + (lambda (rf) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc coll) + (let loop ([a acc] [lst coll]) + (cond + [(null? lst) a] + [(reduced? a) a] + [else (loop (rf a (car lst)) (cdr lst))]))])))) + + ;; (deduplicate) — remove consecutive duplicate elements + (define (deduplicate) + (make-xducer + (lambda (rf) + (let ([prev (box *no-value*)]) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) + (if (and (not (eq? (unbox prev) *no-value*)) + (equal? (unbox prev) x)) + acc + (begin + (set-box! prev x) + (rf acc x)))]))))) + + (define *no-value* (list 'no-value)) ;; unique sentinel + + ;; (partitioning-by f) — group consecutive elements with same (f item) + ;; Emits a list of lists; each partition is emitted when the key changes. + (define (partitioning-by f) + (make-xducer + (lambda (rf) + (let ([current-key (box *no-value*)] + [current-buf (box '())]) + (case-lambda + [() (rf)] + [(acc) + ;; Flush any remaining partition + (let ([buf (reverse (unbox current-buf))]) + (if (null? buf) + (rf acc) + (rf (rf acc buf))))] + [(acc x) + (let ([key (f x)]) + (cond + [(eq? (unbox current-key) *no-value*) + ;; First element + (set-box! current-key key) + (set-box! current-buf (list x)) + acc] + [(equal? (unbox current-key) key) + ;; Same partition + (set-box! current-buf (cons x (unbox current-buf))) + acc] + [else + ;; New partition — emit the old one + (let ([buf (reverse (unbox current-buf))]) + (set-box! current-key key) + (set-box! current-buf (list x)) + (rf acc buf))]))]))))) + + ;; (windowing n) — sliding windows of size n as lists + (define (windowing n) + (make-xducer + (lambda (rf) + (let ([buf (box '())] ;; buffer (recent n items, newest first) + [cnt (box 0)]) ;; number of items seen + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) + (let ([new-cnt (fx+ (unbox cnt) 1)]) + (set-box! cnt new-cnt) + ;; Prepend x and keep at most n items + (let* ([new-buf (cons x (unbox buf))] + [trimmed (if (fx> (length new-buf) n) + (list-head new-buf n) + new-buf)]) + (set-box! buf trimmed) + (if (fx>= new-cnt n) + ;; Full window available — emit in original order + (rf acc (reverse trimmed)) + acc)))]))))) + + ;; (indexing) — pair each element with its 0-based index: (index . item) + (define (indexing) + (make-xducer + (lambda (rf) + (let ([idx (box 0)]) + (case-lambda + [() (rf)] + [(acc) (rf acc)] + [(acc x) + (let ([i (unbox idx)]) + (set-box! idx (fx+ i 1)) + (rf acc (cons i x)))]))))) +