Migrate 3 protocol-using .sls (repl, distributed, wasi)
ober
277c0c82994fd0dacda8886962e2f3095bf28b8a
deleted file mode 100644 --- a/lib/std/distributed.sls +++ /dev/null @@ -1,135 +0,0 @@ -#!chezscheme -;;; (std distributed) — Transparent distributed computation -;;; -;;; Spawn computations across nodes. Closures serialized via FASL. -;;; Limited to pure (serializable) computations. -;;; -;;; API: -;;; (make-cluster nodes) — create cluster from node addresses -;;; (distributed-map cluster proc data) — map proc over data across cluster -;;; (distributed-eval cluster expr) — evaluate expression on remote node -;;; (local-cluster n) — create local cluster with n workers -;;; (cluster-size cluster) — number of nodes - -(library (std distributed) - (export make-cluster distributed-map distributed-eval - local-cluster cluster-size cluster? - worker-eval make-worker worker?) - - (import (chezscheme)) - - ;; ========== Worker (local thread-based) ========== - - (define-record-type worker - (fields - (immutable id) - (immutable input-mutex) - (immutable input-cv) - (immutable output-mutex) - (immutable output-cv) - (mutable task) ;; thunk or #f - (mutable result) ;; result or #f - (mutable busy?) - (immutable thread)) - (protocol - (lambda (new) - (lambda (id) - (let ([im (make-mutex)] - [ic (make-condition)] - [om (make-mutex)] - [oc (make-condition)] - [w #f]) - (set! w (new id im ic om oc #f #f #f - (fork-thread - (lambda () - (let loop () - (with-mutex im - (let wait () - (unless (worker-task w) - (condition-wait ic im) - (wait)))) - (let ([task (worker-task w)]) - (guard (exn - [#t (worker-result-set! w (cons 'error exn))]) - (worker-result-set! w (cons 'ok (task))))) - (worker-busy?-set! w #f) - (with-mutex om - (condition-broadcast oc)) - (worker-task-set! w #f) - (loop)))))) - w))))) - - (define (worker-eval worker thunk) - (with-mutex (worker-input-mutex worker) - (worker-task-set! worker thunk) - (worker-busy?-set! worker #t) - (condition-broadcast (worker-input-cv worker))) - ;; Wait for result - (with-mutex (worker-output-mutex worker) - (let loop () - (when (worker-busy? worker) - (condition-wait (worker-output-cv worker) (worker-output-mutex worker)) - (loop)))) - (let ([r (worker-result worker)]) - (worker-result-set! worker #f) - (if (eq? (car r) 'ok) - (cdr r) - (error 'worker-eval "remote computation failed" (cdr r))))) - - ;; ========== Cluster ========== - - (define-record-type cluster - (fields - (immutable workers) ;; vector of workers - (immutable size)) - (protocol - (lambda (new) - (lambda (workers) - (new (list->vector workers) (length workers)))))) - - (define (local-cluster n) - (make-cluster - (let loop ([i 0] [acc '()]) - (if (= i n) (reverse acc) - (loop (+ i 1) (cons (make-worker i) acc)))))) - - ;; ========== Distributed operations ========== - - (define (distributed-map cluster proc data-chunks) - (let* ([workers (cluster-workers cluster)] - [n (vector-length workers)] - [results (make-vector (length data-chunks) #f)] - [threads '()]) - ;; Distribute chunks to workers round-robin - (let loop ([chunks data-chunks] [i 0] [idx 0]) - (unless (null? chunks) - (let ([worker (vector-ref workers (modulo i n))] - [chunk (car chunks)] - [result-idx idx]) - (set! threads - (cons (fork-thread - (lambda () - (vector-set! results result-idx - (worker-eval worker (lambda () (proc chunk)))))) - threads)) - (loop (cdr chunks) (+ i 1) (+ idx 1))))) - ;; Wait for all - (for-each (lambda (t) - (guard (exn [#t (void)]))) - threads) - ;; Small delay for threads to complete - (let wait-loop ([attempts 0]) - (when (and (< attempts 100) - (let check ([j 0]) - (if (= j (length data-chunks)) #f - (if (not (vector-ref results j)) #t - (check (+ j 1)))))) - ((sleep (make-time 'time-duration 1000000 0))) - (wait-loop (+ attempts 1)))) - (vector->list results))) - - (define (distributed-eval cluster expr) - (let ([worker (vector-ref (cluster-workers cluster) 0)]) - (worker-eval worker (lambda () (eval expr))))) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/distributed.ss @@ -0,0 +1,133 @@ +#!chezscheme +;;; (std distributed) — Transparent distributed computation +;;; +;;; Spawn computations across nodes. Closures serialized via FASL. +;;; Limited to pure (serializable) computations. +;;; +;;; API: +;;; (make-cluster nodes) — create cluster from node addresses +;;; (distributed-map cluster proc data) — map proc over data across cluster +;;; (distributed-eval cluster expr) — evaluate expression on remote node +;;; (local-cluster n) — create local cluster with n workers +;;; (cluster-size cluster) — number of nodes + +(library (std distributed) + (export make-cluster distributed-map distributed-eval + local-cluster cluster-size cluster? + worker-eval make-worker worker?) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch finally)) + + ;; ========== Worker (local thread-based) ========== + + (defstruct worker-raw (id input-mutex input-cv output-mutex output-cv task result busy? thread)) + (def (make-worker id) (let ([im (make-mutex)] + [ic (make-condition)] + [om (make-mutex)] + [oc (make-condition)] + [w #f]) + (set! w (make-worker-raw id im ic om oc #f #f #f + (fork-thread + (lambda () + (let loop () + (with-mutex im + (let wait () + (unless (worker-task w) + (condition-wait ic im) + (wait)))) + (let ([task (worker-task w)]) + (try (worker-result-set! w (cons 'ok (task))) + (catch (exn) (worker-result-set! w (cons 'error exn))))) + (worker-busy?-set! w #f) + (with-mutex om + (condition-broadcast oc)) + (worker-task-set! w #f) + (loop)))))) + w)) + (def worker? worker-raw?) + (def worker-id worker-raw-id) + (def worker-input-mutex worker-raw-input-mutex) + (def worker-input-cv worker-raw-input-cv) + (def worker-output-mutex worker-raw-output-mutex) + (def worker-output-cv worker-raw-output-cv) + (def worker-task worker-raw-task) + (def worker-task-set! worker-raw-task-set!) + (def worker-result worker-raw-result) + (def worker-result-set! worker-raw-result-set!) + (def worker-busy? worker-raw-busy?) + (def worker-busy?-set! worker-raw-busy?-set!) + (def worker-thread worker-raw-thread) + + (def (worker-eval worker thunk) + (with-mutex (worker-input-mutex worker) + (worker-task-set! worker thunk) + (worker-busy?-set! worker #t) + (condition-broadcast (worker-input-cv worker))) + ;; Wait for result + (with-mutex (worker-output-mutex worker) + (let loop () + (when (worker-busy? worker) + (condition-wait (worker-output-cv worker) (worker-output-mutex worker)) + (loop)))) + (let ([r (worker-result worker)]) + (worker-result-set! worker #f) + (if (eq? (car r) 'ok) + (cdr r) + (error 'worker-eval "remote computation failed" (cdr r))))) + + ;; ========== Cluster ========== + + (defstruct cluster-raw (workers size)) + (def (make-cluster workers) (make-cluster-raw (list->vector workers) (length workers))) + (def cluster? cluster-raw?) + (def cluster-workers cluster-raw-workers) + (def cluster-size cluster-raw-size) + + (def (local-cluster n) + (make-cluster + (let loop ([i 0] [acc '()]) + (if (= i n) (reverse acc) + (loop (+ i 1) (cons (make-worker i) acc)))))) + + ;; ========== Distributed operations ========== + + (def (distributed-map cluster proc data-chunks) + (let* ([workers (cluster-workers cluster)] + [n (vector-length workers)] + [results (make-vector (length data-chunks) #f)] + [threads '()]) + ;; Distribute chunks to workers round-robin + (let loop ([chunks data-chunks] [i 0] [idx 0]) + (unless (null? chunks) + (let ([worker (vector-ref workers (modulo i n))] + [chunk (car chunks)] + [result-idx idx]) + (set! threads + (cons (fork-thread + (lambda () + (vector-set! results result-idx + (worker-eval worker (lambda () (proc chunk)))))) + threads)) + (loop (cdr chunks) (+ i 1) (+ idx 1))))) + ;; Wait for all (no-op; results gathered by wait-loop below) + (for-each (lambda (t) + (try (void) + (catch (exn) (void)))) + threads) + ;; Small delay for threads to complete + (let wait-loop ([attempts 0]) + (when (and (< attempts 100) + (let check ([j 0]) + (if (= j (length data-chunks)) #f + (if (not (vector-ref results j)) #t + (check (+ j 1)))))) + ((sleep (make-time 'time-duration 1000000 0))) + (wait-loop (+ attempts 1)))) + (vector->list results))) + + (def (distributed-eval cluster expr) + (let ([worker (vector-ref (cluster-workers cluster) 0)]) + (worker-eval worker (lambda () (eval expr))))) + +) ;; end library deleted file mode 100644 --- a/lib/std/repl.sls +++ /dev/null @@ -1,1592 +0,0 @@ -#!chezscheme -;;; (std repl) -- World-class Interactive REPL -;;; -;;; Inspired by SLIME/SWANK for Common Lisp, this REPL provides: -;;; -;;; Value History: -;;; * ** *** -- last 3 results (CL-style) -;;; $1 $2 $3 ... -- numbered result history -;;; -;;; Inspection & Exploration: -;;; ,type expr -- show type of expression result -;;; ,describe expr -- deep inspection of value (records, lists, hashes) -;;; ,inspect expr -- interactive inspector for complex values -;;; ,apropos str -- search for symbols matching string -;;; ,doc sym -- show documentation -;;; ,complete prefix -- show completions for a symbol prefix -;;; ,who sym -- find all bindings referencing a symbol -;;; -;;; Evaluation & Debugging: -;;; ,expand expr -- show macro expansion -;;; ,expand1 expr -- show one-step macro expansion -;;; ,trace fn -- enable tracing for a function -;;; ,untrace fn -- disable tracing -;;; ,trace-all -- show all traced functions -;;; ,step expr -- step through evaluation (display bindings) -;;; -;;; Performance: -;;; ,time expr -- measure evaluation time (CPU + real + GC) -;;; ,bench expr [n] -- benchmark with N iterations (default 100) -;;; ,profile expr -- profile with Chez's built-in profiler -;;; ,alloc expr -- show memory allocation for expression -;;; -;;; Module System: -;;; ,import (mod ...) -- import a module into the REPL environment -;;; ,reload path -- reload a file (clearing old bindings) -;;; ,cd [path] -- change/show current directory -;;; ,pwd -- show current directory -;;; ,ls [path] -- list directory contents -;;; ,shell cmd -- run a shell command -;;; -;;; Data Inspection: -;;; ,pp expr -- pretty-print value -;;; ,table expr -- display as aligned table (lists of alists/lists) -;;; ,json expr -- display value as JSON -;;; ,csv expr -- display value as CSV -;;; ,head expr [n] -- show first N items (default 10) -;;; ,tail expr [n] -- show last N items (default 10) -;;; ,count expr -- count items in collection -;;; ,stats expr -- column statistics for numeric lists -;;; ,freq expr -- frequency table for a list -;;; -;;; Session: -;;; ,history [n] -- show last N history entries -;;; ,save path -- save session history to file -;;; ,load path -- load and evaluate a file -;;; ,clear -- clear value history -;;; ,reset -- reset environment -;;; ,set key val -- set REPL option (prompt, color, time) -;;; ,env [pattern] -- list environment symbols, optionally filtered -;;; ,help [cmd] -- show help (detailed help for a command) -;;; ,quit -- exit REPL -;;; -;;; Usage: -;;; (import (std repl)) -;;; (jerboa-repl) ; start the enhanced REPL -;;; (jerboa-repl config) ; start with custom config - -(library (std repl) - (export - ;; Main entry point - jerboa-repl - - ;; Individual REPL commands (usable from code) - repl-type repl-time repl-doc repl-apropos repl-expand - repl-pp repl-load - - ;; REPL configuration - make-repl-config repl-config? - repl-config-prompt repl-config-history-size - repl-config-show-time? repl-config-color? - - ;; Utilities - value->type-string describe-value - - ;; Documentation registry - register-doc! - - ;; Completion - repl-complete - - ;; Value history access - repl-history-ref) - - (import (except (chezscheme) cpu-time box?) - (except (std misc list) partition)) - - ;;; ========== REPL Configuration ========== - (define-record-type repl-config - (fields (mutable prompt) ; string: e.g. "jerboa> " - (mutable history-size) ; fixnum: max history entries - (mutable show-time?) ; boolean: auto-show timing - (mutable color?)) ; boolean: ANSI colors - (protocol (lambda (new) - (lambda () - (new "jerboa> " 1000 #f #t))))) - - (define *default-config* (make-repl-config)) - - ;;; ========== ANSI color codes ========== - (define reset-color "\x1b;[0m") - (define bold "\x1b;[1m") - (define dim "\x1b;[2m") - (define italic "\x1b;[3m") - (define underline "\x1b;[4m") - (define red "\x1b;[31m") - (define green "\x1b;[32m") - (define yellow "\x1b;[33m") - (define blue "\x1b;[34m") - (define magenta "\x1b;[35m") - (define cyan "\x1b;[36m") - (define white "\x1b;[37m") - (define bright-black "\x1b;[90m") - - (define (colored cfg color str) - (if (repl-config-color? cfg) - (string-append color str reset-color) - str)) - - (define (c-bold cfg str) - (if (repl-config-color? cfg) - (string-append bold str reset-color) - str)) - - (define (c-dim cfg str) - (if (repl-config-color? cfg) - (string-append bright-black str reset-color) - str)) - - ;;; ========== Value History ========== - ;; CL-style: *, **, *** for last 3 results - ;; Numbered: $1, $2, ... for all results - - (define *value-history* '()) ;; list of (index . value) newest first - (define *history-counter* 0) - (define *last-1* (void)) ;; * - (define *last-2* (void)) ;; ** - (define *last-3* (void)) ;; *** - - (define (history-push! val) - (set! *history-counter* (+ *history-counter* 1)) - (set! *value-history* - (cons (cons *history-counter* val) - (if (> (length *value-history*) 999) - (take *value-history* 999) - *value-history*))) - ;; Shift CL-style history - (set! *last-3* *last-2*) - (set! *last-2* *last-1*) - (set! *last-1* val) - *history-counter*) - - (define (repl-history-ref n) - (let ([entry (assv n *value-history*)]) - (if entry (cdr entry) - (error 'repl-history-ref "no history entry" n)))) - - (define (history-clear!) - (set! *value-history* '()) - (set! *history-counter* 0) - (set! *last-1* (void)) - (set! *last-2* (void)) - (set! *last-3* (void))) - - ;; Install history variables into environment - (define (install-history-bindings! env) - (eval '(define * (void)) env) - (eval '(define ** (void)) env) - (eval '(define *** (void)) env)) - - (define (update-history-bindings! env) - (eval `(set! * ',*last-1*) env) - (eval `(set! ** ',*last-2*) env) - (eval `(set! *** ',*last-3*) env)) - - ;;; ========== Input History ========== - (define *input-history* '()) ;; list of strings, newest first - - (define (input-history-push! str) - (when (and (> (string-length str) 0) - (or (null? *input-history*) - (not (string=? str (car *input-history*))))) - (set! *input-history* (cons str *input-history*)) - (when (> (length *input-history*) 1000) - (set! *input-history* (take *input-history* 1000))))) - - ;;; ========== Persistent History ========== - (define (history-file-path) - (let ([home (or (getenv "HOME") ".")]) - (string-append home "/.jerboa_history"))) - - (define (save-history!) - (guard (exn [#t (void)]) ;; silently fail - (let ([path (history-file-path)]) - (call-with-output-file path - (lambda (p) - (for-each (lambda (line) (display line p) (newline p)) - (reverse (take *input-history* - (min 500 (length *input-history*)))))) - 'replace)))) - - (define (load-history!) - (guard (exn [#t (void)]) - (let ([path (history-file-path)]) - (when (file-exists? path) - (call-with-input-file path - (lambda (p) - (let loop ([lines '()]) - (let ([line (get-line p)]) - (if (eof-object? line) - (set! *input-history* (reverse lines)) - (loop (cons line lines))))))))))) - - ;;; ========== Traced Functions ========== - (define *traced-fns* '()) ;; list of symbols - - ;;; ========== Type inference ========== - (define (value->type-string v) - (cond - [(boolean? v) "Boolean"] - [(fixnum? v) "Fixnum"] - [(flonum? v) "Flonum"] - [(bignum? v) "Bignum"] - [(rational? v) "Rational"] - [(complex? v) "Complex"] - [(char? v) "Char"] - [(string? v) (format "String[~a]" (string-length v))] - [(symbol? v) (if (keyword? v) "Keyword" "Symbol")] - [(null? v) "Null"] - [(pair? v) - (cond - [(not (list? v)) "Pair"] - [(and (> (length v) 0) (pair? (car v)) - (every pair? v)) - (format "AList[~a]" (length v))] - [else (format "List[~a]" (length v))])] - [(vector? v) (format "Vector[~a]" (vector-length v))] - [(bytevector? v) (format "Bytevector[~a]" (bytevector-length v))] - [(port? v) - (cond - [(and (input-port? v) (output-port? v)) "InputOutputPort"] - [(input-port? v) "InputPort"] - [else "OutputPort"])] - [(procedure? v) "Procedure"] - [(hashtable? v) (format "HashTable[~a]" (hashtable-size v))] - [(void-object? v) "Void"] - [(condition? v) - (if (message-condition? v) - (format "Condition(~a)" (condition-message v)) - "Condition")] - [(eq? v #!eof) "EOF"] - [(box? v) "Box"] - [(fxvector? v) (format "FxVector[~a]" (fxvector-length v))] - [else - (guard (exn [#t "Unknown"]) - (let ([rtd (record-rtd v)]) - (symbol->string (record-type-name rtd))))])) - - (define (keyword? v) - (and (symbol? v) - (let ([s (symbol->string v)]) - (and (> (string-length s) 0) - (char=? (string-ref s 0) #\:))))) - - (define (void-object? v) (eq? v (void))) - (define (box? v) - (guard (exn [#t #f]) - (and (record? v) (eq? (record-type-name (record-rtd v)) 'box)))) - - ;;; ========== Rich describe-value ========== - (define (describe-value v . port-opt) - (let ([port (if (pair? port-opt) (car port-opt) (current-output-port))]) - (display (value->type-string v) port) - (display ": " port) - (write v port) - (newline port))) - - (define (deep-describe cfg v port) - ;; Rich multi-line description of a value - (display (colored cfg cyan (value->type-string v)) port) - (newline port) - (cond - [(hashtable? v) - (fprintf port " size: ~a~n" (hashtable-size v)) - (let-values ([(keys vals) (hashtable-entries v)]) - (let ([n (vector-length keys)]) - (do ([i 0 (+ i 1)]) - ((or (= i n) (= i 20))) - (fprintf port " ~a: " (vector-ref keys i)) - (write (vector-ref vals i) port) - (newline port)) - (when (> n 20) - (fprintf port " ... and ~a more entries~n" (- n 20)))))] - [(and (list? v) (> (length v) 0)) - (fprintf port " length: ~a~n" (length v)) - (let ([n (min 10 (length v))]) - (do ([i 0 (+ i 1)] [l v (cdr l)]) - ((= i n)) - (fprintf port " [~a] " i) - (let ([item (car l)]) - (if (> (string-length (format "~s" item)) 72) - (begin (display (value->type-string item) port) - (display " ..." port)) - (write item port))) - (newline port)) - (when (> (length v) 10) - (fprintf port " ... and ~a more items~n" (- (length v) 10))))] - [(vector? v) - (fprintf port " length: ~a~n" (vector-length v)) - (let ([n (min 10 (vector-length v))]) - (do ([i 0 (+ i 1)]) - ((= i n)) - (fprintf port " [~a] " i) - (write (vector-ref v i) port) - (newline port)) - (when (> (vector-length v) 10) - (fprintf port " ... and ~a more elements~n" (- (vector-length v) 10))))] - [(string? v) - (fprintf port " length: ~a~n" (string-length v)) - (when (> (string-length v) 80) - (fprintf port " preview: ~a...~n" (substring v 0 77)))] - [(bytevector? v) - (fprintf port " length: ~a bytes~n" (bytevector-length v)) - (let ([n (min 32 (bytevector-length v))]) - (display " hex: " port) - (do ([i 0 (+ i 1)]) - ((= i n)) - (let* ([b (bytevector-u8-ref v i)] - [s (number->string b 16)]) - (when (< b 16) (display "0" port)) - (display s port) - (display " " port))) - (when (> (bytevector-length v) 32) - (display "..." port)) - (newline port))] - [(procedure? v) - (let ([info (guard (e [#t #f]) (#%$code-name (#%$closure-code v)))]) - (when info - (fprintf port " name: ~a~n" info)))] - [(and (record? v) (not (condition? v))) - (guard (exn [#t (void)]) - (fprintf port " fields:~n") - (for-each - (lambda (pair) - (fprintf port " ~a: " (car pair)) - (write (cdr pair) port) - (newline port)) - (record->alist v)) - (let ([parent (record-type-parent (record-rtd v))]) - (when parent - (fprintf port " parent: ~a~n" (record-type-name parent)))))] - [(condition? v) - (when (message-condition? v) - (fprintf port " message: ~a~n" (condition-message v))) - (when (irritants-condition? v) - (fprintf port " irritants: ~s~n" (condition-irritants v)))] - [(pair? v) - (fprintf port " car: ~s~n" (car v)) - (fprintf port " cdr: ~s~n" (cdr v))] - [else - (display " value: " port) - (write v port) - (newline port)])) - - ;;; ========== Table Display ========== - (define (display-table cfg data port) - ;; Display a list of lists as an aligned table - ;; data: list of rows (each row is a list of values) - (when (and (pair? data) (pair? (car data))) - (let* ([rows (map (lambda (row) - (map (lambda (v) (format "~a" v)) row)) - data)] - [ncols (apply max (map length rows))] - ;; Pad short rows - [rows (map (lambda (row) - (let ([n (length row)]) - (if (< n ncols) - (append row (make-list (- ncols n) "")) - row))) - rows)] - ;; Compute column widths - [widths (let loop ([col 0] [acc '()]) - (if (= col ncols) - (reverse acc) - (loop (+ col 1) - (cons (apply max 1 - (map (lambda (row) - (string-length (list-ref row col))) - rows)) - acc))))]) - ;; Print header separator - (let ([header (car rows)] - [body (cdr rows)]) - ;; Print header - (let loop ([h header] [w widths]) - (when (pair? h) - (display (colored cfg bold (car h)) port) - (display (make-string (max 0 (- (car w) (string-length (car h)))) #\space) port) - (when (pair? (cdr h)) (display " " port)) - (loop (cdr h) (cdr w)))) - (newline port) - ;; Separator line - (let loop ([w widths]) - (when (pair? w) - (display (make-string (car w) #\-) port) - (when (pair? (cdr w)) (display " " port)) - (loop (cdr w)))) - (newline port) - ;; Print body rows - (for-each - (lambda (row) - (let loop ([r row] [w widths]) - (when (pair? r) - (display (car r) port) - (display (make-string (max 0 (- (car w) (string-length (car r)))) #\space) port) - (when (pair? (cdr r)) (display " " port)) - (loop (cdr r) (cdr w)))) - (newline port)) - body))))) - - ;; Convert various data shapes to table rows - (define (value->table-rows v) - (cond - ;; List of alists: [{(name . "a") (age . 1)} ...] - [(and (list? v) (pair? v) (pair? (car v)) - (every (lambda (x) (and (pair? x) (every pair? x))) v)) - (let* ([all-keys (unique (apply append (map (lambda (row) (map car row)) v)))] - [header (map symbol->string all-keys)]) - (cons header - (map (lambda (row) - (map (lambda (key) - (let ([pair (assq key row)]) - (if pair (format "~a" (cdr pair)) ""))) - all-keys)) - v)))] - ;; List of lists - [(and (list? v) (pair? v) (every list? v)) - v] - ;; Hash table - [(hashtable? v) - (let-values ([(keys vals) (hashtable-entries v)]) - (cons (list "key" "value") - (let loop ([i 0] [acc '()]) - (if (= i (vector-length keys)) - (reverse acc) - (loop (+ i 1) - (cons (list (format "~a" (vector-ref keys i)) - (format "~a" (vector-ref vals i))) - acc))))))] - [else #f])) - - ;;; ========== Frequency Table ========== - (define (frequency-table lst) - (let ([ht (make-hashtable equal-hash equal?)]) - (for-each (lambda (v) - (hashtable-update! ht v (lambda (c) (+ c 1)) 0)) - lst) - (let-values ([(keys vals) (hashtable-entries ht)]) - (let ([pairs (let loop ([i 0] [acc '()]) - (if (= i (vector-length keys)) - acc - (loop (+ i 1) - (cons (cons (vector-ref keys i) (vector-ref vals i)) - acc))))]) - ;; Sort by count descending - (sort (lambda (a b) (> (cdr a) (cdr b))) pairs))))) - - ;;; ========== Numeric Statistics ========== - (define (list-stats lst) - ;; Returns alist of statistics for a numeric list - (if (or (null? lst) (not (every number? lst))) - '() - (let* ([sorted (sort < lst)] - [n (length sorted)] - [total (apply + sorted)] - [mean (/ total n)] - [lo (car sorted)] - [hi (car (reverse sorted))] - [median (if (odd? n) - (list-ref sorted (quotient n 2)) - (/ (+ (list-ref sorted (- (quotient n 2) 1)) - (list-ref sorted (quotient n 2))) - 2))] - [variance (/ (apply + (map (lambda (x) (expt (- x mean) 2)) sorted)) n)] - [stddev (sqrt (inexact variance))]) - `((count . ,n) - (mean . ,(inexact mean)) - (std . ,stddev) - (min . ,lo) - (25% . ,(list-ref sorted (quotient n 4))) - (50% . ,median) - (75% . ,(list-ref sorted (quotient (* 3 n) 4))) - (max . ,hi) - (sum . ,total))))) - - ;;; ========== Timing ========== - (define (cpu-time) - (let ([t (current-time 'time-process)]) - (+ (* (time-second t) 1000) - (quotient (time-nanosecond t) 1000000)))) - - (define (real-time-ms) - (let ([t (current-time 'time-monotonic)]) - (+ (* (time-second t) 1000) - (quotient (time-nanosecond t) 1000000)))) - - (define (time-thunk thunk) - (let* ([gc-before (statistics)] - [t-before (cpu-time)] - [r-before (real-time-ms)] - [result (thunk)] - [t-after (cpu-time)] - [r-after (real-time-ms)] - [gc-after (statistics)]) - (values result - (- t-after t-before) ; CPU ms - (- r-after r-before)))) ; Real ms - - (define (time-thunk/detailed thunk) - ;; Returns (values result cpu-ms real-ms gc-count bytes-allocated) - (collect (collect-maximum-generation)) - (let* ([stats0 (statistics)] - [t0 (cpu-time)] - [r0 (real-time-ms)] - [result (thunk)] - [t1 (cpu-time)] - [r1 (real-time-ms)] - [stats1 (statistics)]) - ;; statistics returns an alist with gc-count, cpu-time, bytes-allocated, etc. - (values result - (- t1 t0) - (- r1 r0) - stats0 - stats1))) - - ;;; ========== Benchmarking ========== - (define (benchmark-thunk thunk iterations) - (collect (collect-maximum-generation)) - (let ([t0 (real-time-ms)]) - (do ([i 0 (+ i 1)]) - ((= i iterations)) - (thunk)) - (let* ([t1 (real-time-ms)] - [total (- t1 t0)] - [per-iter (if (> iterations 0) (/ (inexact total) iterations) 0.0)]) - (values total per-iter iterations)))) - - ;;; ========== Documentation lookup ========== - (define *doc-registry* (make-hash-table)) - - (define (register-doc! sym doc-string) - (hashtable-set! *doc-registry* sym doc-string)) - - (define (repl-doc sym) - (or (hashtable-ref *doc-registry* sym #f) - (format "No documentation found for '~a'" sym))) - - ;;; ========== Apropos search ========== - (define (repl-apropos query . env-opt) - (let* ([env (if (pair? env-opt) (car env-opt) (interaction-environment))] - [syms (environment-symbols env)] - [q (string-downcase query)]) - (filter - (lambda (sym) - (let ([s (string-downcase (symbol->string sym))]) - (string-contains s q))) - (if (list? syms) syms '())))) - - ;;; ========== Completion ========== - (define (repl-complete prefix . env-opt) - (let* ([env (if (pair? env-opt) (car env-opt) (interaction-environment))] - [syms (environment-symbols env)] - [pfx (string-downcase prefix)]) - (sort (lambda (a b) (string<? (symbol->string a) (symbol->string b))) - (filter - (lambda (sym) - (let ([s (string-downcase (symbol->string sym))]) - (and (>= (string-length s) (string-length pfx)) - (string=? (substring s 0 (string-length pfx)) pfx)))) - (if (list? syms) syms '()))))) - - ;;; ========== String Helpers ========== - (define (string-contains haystack needle) - (let ([hn (string-length haystack)] - [nn (string-length needle)]) - (let loop ([i 0]) - (cond - [(> (+ i nn) hn) #f] - [(string=? (substring haystack i (+ i nn)) needle) #t] - [else (loop (+ i 1))])))) - - (define (string-trim str) - (let* ([n (string-length str)] - [s (let loop ([i 0]) - (if (or (= i n) (not (char-whitespace? (string-ref str i)))) - i - (loop (+ i 1))))] - [e (let loop ([i (- n 1)]) - (if (or (< i 0) (not (char-whitespace? (string-ref str i)))) - (+ i 1) - (loop (- i 1))))]) - (if (>= s e) "" (substring str s e)))) - - (define (string-split-first-word str) - (let* ([n (string-length str)] - [sp (let loop ([i 0]) - (if (or (= i n) (char-whitespace? (string-ref str i))) - i - (loop (+ i 1))))]) - (cons (substring str 0 sp) - (if (= sp n) - "" - (string-trim (substring str sp n)))))) - - (define (string-starts-with? str prefix) - (and (>= (string-length str) (string-length prefix)) - (string=? (substring str 0 (string-length prefix)) prefix))) - - (define (string-join-with strs sep) - (if (null? strs) "" - (let loop ([rest (cdr strs)] [acc (car strs)]) - (if (null? rest) acc - (loop (cdr rest) (string-append acc sep (car rest))))))) - - ;;; ========== Expand macro ========== - (define (repl-expand expr env) - (guard (exn [#t (format "Expansion error: ~a" exn)]) - (expand expr env))) - - ;;; ========== Pretty print ========== - (define (repl-pp val . port-opt) - (let ([port (if (pair? port-opt) (car port-opt) (current-output-port))]) - (pretty-print val port))) - - ;;; ========== Load file ========== - (define (repl-load path env) - (guard (exn [#t (format "Load error: ~a" exn)]) - (load path (lambda (x) (eval x env))))) - - ;;; ========== Type annotation ========== - (define (repl-type val . port-opt) - (let ([port (if (pair? port-opt) (car port-opt) (current-output-port))]) - (display (value->type-string val) port) - (newline port))) - - ;;; ========== Time command ========== - (define (repl-time thunk . port-opt) - (let ([port (if (pair? port-opt) (car port-opt) (current-output-port))]) - (let* ([t0 (cpu-time)] - [result (thunk)] - [t1 (cpu-time)] - [ms (- t1 t0)]) - (fprintf port ";; ~a ms elapsed~n" ms) - result))) - - ;;; ========== Balanced parens check ========== - (define (balanced? str) - (let loop ([chars (string->list str)] [depth 0] [in-string #f] [escape #f]) - (cond - [(< depth 0) #f] - [(null? chars) (and (= depth 0) (not in-string))] - [else - (let ([c (car chars)]) - (cond - [escape - (loop (cdr chars) depth in-string #f)] - [(char=? c #\\) - (loop (cdr chars) depth in-string #t)] - [in-string - (if (char=? c #\") - (loop (cdr chars) depth #f #f) - (loop (cdr chars) depth #t #f))] - [(char=? c #\") - (loop (cdr chars) depth #t #f)] - [(char=? c #\;) - ;; Skip to end of line - (let skip ([rest (cdr chars)]) - (cond - [(null? rest) (= depth 0)] - [(char=? (car rest) #\newline) - (loop (cdr rest) depth #f #f)] - [else (skip (cdr rest))]))] - [(or (char=? c #\() (char=? c #\[) (char=? c #\{)) - (loop (cdr chars) (+ depth 1) #f #f)] - [(or (char=? c #\)) (char=? c #\]) (char=? c #\})) - (loop (cdr chars) (- depth 1) #f #f)] - [else - (loop (cdr chars) depth #f #f)]))]))) - - ;;; ========== REPL read ========== - (define (repl-read-expr prompt-str port) - (display prompt-str) - (flush-output-port (current-output-port)) - (let ([line (get-line port)]) - (if (eof-object? line) - line - (let ([trimmed (string-trim line)]) - (if (string=? trimmed "") - trimmed - (let complete ([acc trimmed]) - (if (balanced? acc) - acc - (begin - (display " ... ") - (flush-output-port (current-output-port)) - (let ([next (get-line port)]) - (if (eof-object? next) - acc - (complete (string-append acc "\n" next)))))))))))) - - ;;; ========== REPL print ========== - (define (repl-print val env cfg) - (cond - [(eq? val (void)) (void)] - [else - (let ([idx (history-push! val)])