Fix static Docker build: libvterm, stale deps, missing FFI symbols
ober
c3d00863e6e27c7dee52ce5b941522e89acd543c
--- a/Dockerfile +++ b/Dockerfile @@ -31,6 +31,7 @@ RUN apk add --no-cache \ libx11-static graphite2-static libxkbcommon-static \ ncurses-dev ncurses-static \ util-linux-dev util-linux-static \ + libvterm-dev libvterm-static \ gcc g++ binutils make git curl wget # Build static libXau (no Alpine -static package available) --- a/Makefile +++ b/Makefile @@ -258,6 +258,9 @@ CHEZ_MT ?= ta6le CHEZ_MUSL_DIR ?= $(shell ls -d /opt/chez/lib/csv*/$(CHEZ_MT) 2>/dev/null | head -1) build-jemacs-qt-static: check-root + cp /src/vendor/jerboa-shell/embed-crypto.c /deps/jsh/ 2>/dev/null; \ + cp /src/vendor/jerboa-shell/embed-crypto.h /deps/jsh/ 2>/dev/null; \ + cp /src/vendor/jerboa-shell/ffi-shim.c /deps/jsh/ 2>/dev/null; \ cd /src && make build SCHEME=/opt/chez/bin/scheme JERBOA=/deps/jerboa && \ if [ -f /src/vendor/qt_shim.cpp ]; then \ echo "Rebuilding libqt_shim.a from updated qt_shim.cpp..." && \ @@ -290,6 +293,11 @@ build-jemacs-qt-static: check-root JEMACS_STATIC=1 /opt/chez/bin/scheme --libdirs /deps/jerboa/lib \ --compile-imported-libraries --script /src/vendor/jerboa-compile-tcp.ss && \ rm -f /deps/jerboa/lib/std/net/*.wpo && \ + cp /src/vendor/jerboa-repl-static.sls /deps/jerboa/lib/std/repl.sls && \ + rm -f /deps/jerboa/lib/std/repl.wpo /deps/jerboa/lib/std/repl.so && \ + cd /deps/jerboa/lib && /opt/chez/bin/scheme --libdirs /deps/jerboa/lib \ + --compile-imported-libraries --script /src/vendor/jerboa-compile-repl.ss && \ + rm -f /deps/jerboa/lib/std/repl.wpo && cd /src && \ rm -f /src/lib/jerboa/*.wpo /src/lib/jerboa/*.so && \ JEMACS_STATIC=1 /opt/chez/bin/scheme --libdirs /src/lib \ --compile-imported-libraries --script /src/vendor/jerboa-compile-repl-socket.ss && \ @@ -315,7 +323,8 @@ linux-static-qt-docker: --ulimit nofile=8192:8192 \ -v $(CURDIR):/src:z \ $(DEPS_IMAGE) \ - sh -c "chmod 755 /root && \ + sh -c "apk add --no-cache libvterm-dev libvterm-static >/dev/null 2>&1; \ + chmod 755 /root && \ chown -R $(UID):$(GID) /opt/ /deps && \ mkdir -p /tmp/jemacs-build && chown $(UID):$(GID) /tmp/jemacs-build && \ exec su-exec $(UID):$(GID) env HOME=/tmp/jemacs-build sh -c '\ --- a/build-binary-qt.ss +++ b/build-binary-qt.ss @@ -89,25 +89,23 @@ (and v (not (string=? v "0")) (not (string=? v ""))))) ;; Check critical dependencies +;; For static builds, skip checks on .o files that this script compiles in step 5 +;; (jemacs-qt-chez-shim.o, pcre2_shim.o). Only check pre-existing external deps. (for-each (lambda (path label) (unless (file-exists? path) (printf "Error: ~a not found at ~a~n" label path) (exit 1))) - (list (format "~a/jerboa/core.so" jerboa-dir) - (if jemacs-static? - "jemacs-qt-chez-shim.o" ;; built locally from vendor/qt_chez_shim.c - "qt_chez_shim.so") - (if jemacs-static? - (format "~a/pcre2_shim.o" pcre2-dir) - (format "~a/pcre2_shim.so" pcre2-dir)) - (if jemacs-static? - (format "~a/libqt_shim.a" qt-shim-dir) - (format "~a/libqt_shim.so" qt-shim-dir))) - (list "jerboa core.so" - (if jemacs-static? "qt_chez_shim.o" "qt_chez_shim.so") - (if jemacs-static? "pcre2_shim.o" "pcre2_shim.so") - (if jemacs-static? "libqt_shim.a" "libqt_shim.so"))) + (if jemacs-static? + (list (format "~a/jerboa/core.so" jerboa-dir) + (format "~a/libqt_shim.a" qt-shim-dir)) + (list (format "~a/jerboa/core.so" jerboa-dir) + "qt_chez_shim.so" + (format "~a/pcre2_shim.so" pcre2-dir) + (format "~a/libqt_shim.so" qt-shim-dir))) + (if jemacs-static? + (list "jerboa core.so" "libqt_shim.a") + (list "jerboa core.so" "qt_chez_shim.so" "pcre2_shim.so" "libqt_shim.so"))) (printf "Chez dir: ~a~n" chez-dir) (printf "Jerboa dir: ~a~n" jerboa-dir) @@ -421,6 +419,29 @@ echo OK" (display "Error: jsh ffi-shim.c compilation failed\n") (exit 1)))) +;; jsh embed-crypto (pure C crypto for embed encryption — no external deps) +(when jemacs-static? + (let* ((jsh-root (path-parent jsh-dir)) + (cmd (format "gcc -c -O2 -o jemacs-qt-embed-crypto.o ~a/embed-crypto.c -I~a -Wall 2>&1" + jsh-root jsh-root))) + (unless (= 0 (system cmd)) + (display "Error: embed-crypto.c compilation failed\n") + (exit 1)))) + +;; jsh ssh-agent stub (chez_ssh_agent_stop referenced in main.sls but not needed for jemacs) +(when jemacs-static? + (let ((stub-file "jemacs-qt-ssh-agent-stub.c")) + (call-with-output-file stub-file + (lambda (out) + (fprintf out "/* Stub — jemacs doesn't use ssh-agent */~n") + (fprintf out "void chez_ssh_agent_stop(void) {}~n") + (fprintf out "int chez_ssh_agent_is_running(void) { return 0; }~n")) + 'replace) + (let ((cmd (format "gcc -c -O2 -o jemacs-qt-ssh-agent-stub.o ~a -Wall 2>&1" stub-file))) + (unless (= 0 (system cmd)) + (display "Error: ssh-agent stub compilation failed\n") + (exit 1))))) + ;; chez-scintilla stubs (TUI-only — Qt never calls these; stubs allow foreign-procedure defs) (when jemacs-static? (let* ((cmd "gcc -c -O2 -o jemacs-qt-sci-stubs.o support/chez_scintilla_stubs.c -Wall 2>&1")) @@ -484,6 +505,7 @@ echo OK" (libqt-shim (format "~a/libqt_shim.a" qt-shim-dir)) (cmd (format "g++ -static -Wl,--export-dynamic -o jemacs-qt \ jemacs-qt-main.o jemacs-qt-chez-shim.o jemacs-qt-pcre2-shim.o jemacs-qt-jsh-ffi.o \ +jemacs-qt-embed-crypto.o jemacs-qt-ssh-agent-stub.o \ jemacs-qt-pty-shim.o jemacs-qt-vterm-shim.o jemacs-qt-repl-shim.o jemacs-qt-jerboa-landlock.o jemacs-qt-sci-stubs.o \ qt_static_symbols.o \ ~a ~a ~a ~a \ @@ -517,7 +539,9 @@ qt_static_symbols.o \ "jemacs_qt_scheme_boot.h" "jemacs_qt_jemacs_qt_boot.h" "jemacs-qt-all.so" "qt-main.so" "qt-main.wpo" "jemacs-qt.boot") (if jemacs-static? - '("jemacs-qt-jsh-ffi.o" "jemacs-qt-pty-shim.o" "jemacs-qt-vterm-shim.o" + '("jemacs-qt-jsh-ffi.o" "jemacs-qt-embed-crypto.o" + "jemacs-qt-ssh-agent-stub.o" "jemacs-qt-ssh-agent-stub.c" + "jemacs-qt-pty-shim.o" "jemacs-qt-vterm-shim.o" "jemacs-qt-jerboa-landlock.o" "jemacs-qt-sci-stubs.o" "qt_static_symbols.o" "qt_static_symbols.c") '()))) new file mode 100644 --- /dev/null +++ b/vendor/jerboa-compile-repl.ss @@ -0,0 +1,4 @@ +#!chezscheme +(import (chezscheme)) +(parameterize ((compile-imported-libraries #t)) + (compile-library "std/repl.sls")) new file mode 100644 --- /dev/null +++ b/vendor/jerboa-repl-static.sls @@ -0,0 +1,1595 @@ +#!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?) + (std misc list)) + + ;;; ========== 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)]) + (let* ([rtd (record-rtd v)] + [names (record-type-field-names rtd)] + [n (vector-length names)]) + (fprintf port " fields:~n") + (do ([i 0 (+ i 1)]) + ((= i n)) + (fprintf port " ~a: " (vector-ref names i)) + (write ((record-accessor rtd i) v) port) + (newline port)) + (let ([parent (record-type-parent rtd)]) + (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)]) + (update-history-bindings! env) + ;; Show $N tag + (display (colored cfg bright-black (format "$~a " idx))) + (display (colored cfg cyan (format "[~a] " (value->type-string val)))) + ;; Smart printing: use pp for complex, write for simple + (if (or (and (list? val) (> (length val) 3)) + (and (vector? val) (> (vector-length val) 3)) + (hashtable? val) + (and (record? val) (not (condition? val)))) + (begin (newline) (pretty-print val)) + (begin (write val) (newline))))])) + + ;;; ========== Multi-value printing ========== + (define (repl-eval-and-print expr env cfg) + ;; Evaluates expr, handles multiple values, stores in history + (call-with-values + (lambda () (eval expr env)) + (lambda results + (cond + [(null? results) + (void)] + [(= (length results) 1) + (repl-print (car results) env cfg)] + [else + ;; Multiple values + (display (colored cfg magenta ";; multiple values:\n")) + (let loop ([vals results] [i 0]) + (when (pair? vals) + (let ([idx (history-push! (car vals))]) + (update-history-bindings! env) + (display (colored cfg bright-black (format " $~a " idx))) + (display (colored cfg cyan + (format "[~a] " (value->type-string (car vals))))) + (write (car vals)) + (newline)) + (loop (cdr vals) (+ i 1))))])))) + + ;;; ========== Command dispatch ========== + (define (dispatch-command line env cfg) + (let ([parts (string-split-first-word (string-trim line))]) + (let ([cmd (car parts)] + [rest (cdr parts)]) + (cond + ;; ---- Inspection ---- + [(string=? cmd ",type") + (guard (exn [#t (display-error cfg exn)]) + (let* ([expr (with-input-from-string rest read)] + [val (eval expr env)]) + (display (colored cfg cyan (value->type-string val))) + (newline)))] + + [(string=? cmd ",describe") + (guard (exn [#t (display-error cfg exn)]) + (let* ([expr (with-input-from-string rest read)] + [val (eval expr env)]) + (deep-describe cfg val (current-output-port))))] + + [(string=? cmd ",inspect") + (guard (exn [#t (display-error cfg exn)]) + (let* ([expr (with-input-from-string rest read)] + [val (eval expr env)]) + (interactive-inspect cfg val env)))] + + [(string=? cmd ",apropos") + (let* ([q (string-trim rest)] + [syms (repl-apropos q env)] + [sorted (sort (lambda (a b) + (string<? (symbol->string a) (symbol->string b))) + syms)]) + (if (null? sorted) + (display ";; no matches\n") + (begin + (fprintf (current-output-port) ";; ~a matches:~n" (length sorted)) + (for-each (lambda (s) + (display " ") + (display (colored cfg green (symbol->string s))) + ;; Show type of binding + (guard (exn [#t (void)]) + (let ([v (eval s env)]) + (display (c-dim cfg + (format " (~a)" (value->type-string v)))))) + (newline)) + (take sorted (min 30 (length sorted)))) + (when (> (length sorted) 30) + (fprintf (current-output-port) + " ... and ~a more~n" (- (length sorted) 30))))))] + + [(string=? cmd ",doc") + (let ([sym-str (string-trim rest)]) + (display (colored cfg yellow (repl-doc (string->symbol sym-str)))) + (newline))] + + [(string=? cmd ",complete") + (let* ([pfx (string-trim rest)] + [comps (repl-complete pfx env)]) + (if (null? comps) + (display ";; no completions\n") + (begin + (for-each (lambda (s) + (display " ") + (display (colored cfg green (symbol->string s))) + (newline)) + (take comps (min 40 (length comps)))) + (when (> (length comps) 40) + (fprintf (current-output-port) " ... ~a more~n" + (- (length comps) 40))))))] + + [(string=? cmd ",who") + (let* ([q (string-trim rest)] + [sym (string->symbol q)] + [syms (environment-symbols env)]) + (display (format ";; '~a' is " q)) + (guard (exn [#t (display "not bound\n")]) + (let ([v (eval sym env)]) + (display (colored cfg cyan (value->type-string v))) + (newline) + (when (procedure? v) + (let ([name (guard (e [#t #f]) (#%$code-name (#%$closure-code v)))]) + (when name + (fprintf (current-output-port) " procedure-name: ~a~n" name)))))))] + + ;; ---- Evaluation & Debugging ---- + [(string=? cmd ",expand") + (guard (exn [#t (display-error cfg exn)]) + (let* ([expr (with-input-from-string rest read)] + [expanded (expand expr env)]) + (pretty-print expanded)))] + + [(string=? cmd ",expand1") + (guard (exn [#t (display-error cfg exn)]) + (let* ([expr (with-input-from-string rest read)] + [expanded (sc-expand expr)]) + (pretty-print expanded)))] +