Add world-class REPL with SLIME-inspired features and SWANK-like server
ober
3c56af0e6313e8b48c7248b46a47465eb7cd2b6e
--- 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 test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional clean +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl clean test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded @@ -232,6 +232,11 @@ test-phase8: @echo "--- Phase 8: Deep Gerbil Compatibility ---" @$(SCHEME) --libdirs $(LIBDIRS) --program tests/test-phase8.ss +test-repl: + @echo "--- REPL tests ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-repl-enhanced.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-repl-server.ss + test-functional: @echo "--- Functional Tests (real I/O, fork, Landlock, signals) ---" @gcc -shared -fPIC -O2 -o support/libjerboa-landlock.so support/landlock-shim.c 2>/dev/null || true --- a/lib/std/repl.sls +++ b/lib/std/repl.sls @@ -1,21 +1,69 @@ #!chezscheme -;;; (std repl) -- Enhanced Interactive REPL +;;; (std repl) -- World-class Interactive REPL ;;; -;;; Provides a rich interactive REPL with: -;;; ,type expr -- show type of expression result -;;; ,time expr -- measure evaluation time -;;; ,doc sym -- show documentation -;;; ,apropos str -- search for symbols matching string -;;; ,trace (f args) -- trace a function call -;;; ,expand expr -- show macro expansion -;;; ,profile expr -- profile expression -;;; ,pp expr -- pretty-print -;;; ,load path -- load a file -;;; ,env -- list current bindings +;;; 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) ; start the enhanced REPL +;;; (jerboa-repl config) ; start with custom config (library (std repl) (export @@ -32,9 +80,18 @@ repl-config-show-time? repl-config-color? ;; Utilities - value->type-string describe-value) + value->type-string describe-value + + ;; Documentation registry + register-doc! + + ;; Completion + repl-complete - (import (except (chezscheme) cpu-time) + ;; Value history access + repl-history-ref) + + (import (except (chezscheme) cpu-time box?) (std misc list)) ;;; ========== REPL Configuration ========== @@ -50,11 +107,11 @@ (define *default-config* (make-repl-config)) ;;; ========== ANSI color codes ========== - (define (color-code n) - (string-append "\x1b;[" (number->string n) "m")) - (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") @@ -62,14 +119,111 @@ (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 ========== - ;; Returns a human-readable type string for a value. (define (value->type-string v) (cond [(boolean? v) "Boolean"] @@ -79,37 +233,50 @@ [(rational? v) "Rational"] [(complex? v) "Complex"] [(char? v) "Char"] - [(string? v) (string-append "String[" (number->string (string-length v)) "]")] - [(symbol? v) "Symbol"] - [(keyword? v) "Keyword"] + [(string? v) (format "String[~a]" (string-length v))] + [(symbol? v) (if (keyword? v) "Keyword" "Symbol")] [(null? v) "Null"] [(pair? v) - (if (list? v) - (string-append "List[" (number->string (length v)) "]") - "Pair")] - [(vector? v) (string-append "Vector[" (number->string (vector-length v)) "]")] - [(bytevector? v) (string-append "Bytevector[" (number->string (bytevector-length v)) "]")] - [(port? v) (if (input-port? v) "InputPort" "OutputPort")] + (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"] - [(hash-table? v) (string-append "HashTable[" (number->string (hashtable-size v)) "]")] + [(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 - ;; Try to get record type name (guard (exn [#t "Unknown"]) (let ([rtd (record-rtd v)]) (symbol->string (record-type-name rtd))))])) (define (keyword? v) - ;; Keywords are symbols starting with ':' -- simplified check (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 (void-object? v) (eq? v (void))) + (define (box? v) + (guard (exn [#t #f]) + (and (record? v) (eq? (record-type-name (record-rtd v)) 'box)))) - ;;; ========== describe-value ========== + ;;; ========== 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) @@ -117,25 +284,279 @@ (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 time in milliseconds - ))) + (- t-after t-before) ; CPU ms + (- r-after r-before)))) ; Real ms - (define (cpu-time) - ;; Returns CPU time in milliseconds - (let ([t (current-time 'time-process)]) - (+ (* (time-second t) 1000) - (quotient (time-nanosecond t) 1000000)))) + (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 ========== - ;; Simple documentation registry (define *doc-registry* (make-hash-table)) (define (register-doc! sym doc-string) @@ -147,7 +568,6 @@ ;;; ========== Apropos search ========== (define (repl-apropos query . env-opt) - ;; Search for identifiers containing query as a substring (let* ([env (if (pair? env-opt) (car env-opt) (interaction-environment))] [syms (environment-symbols env)] [q (string-downcase query)]) @@ -157,6 +577,20 @@ (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)]) @@ -166,6 +600,39 @@ [(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)]) @@ -181,7 +648,7 @@ (guard (exn [#t (format "Load error: ~a" exn)]) (load path (lambda (x) (eval x env))))) - ;;; ========== REPL command type annotation ========== + ;;; ========== 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) @@ -197,161 +664,831 @@ (fprintf port ";; ~a ms elapsed~n" ms) result))) - ;;; ========== Helpers (defined early for forward-reference safety) ========== - (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)))) + ;;; ========== 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)]))]))) - (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)))))) + ;;; ========== 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) - ;; Parses REPL commands starting with "," (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 (format "Error: ~a~n" exn))]) + (guard (exn [#t (display-error cfg exn)]) (let* ([expr (with-input-from-string rest read)] - [val (eval expr env)] - [type-s (value->type-string val)]) - (display (colored cfg cyan type-s)) + [val (eval expr env)]) + (display (colored cfg cyan (value->type-string val))) (newline)))] - [(string=? cmd ",time") - (guard (exn [#t (display (format "Error: ~a~n" exn))]) - (let ([expr (with-input-from-string rest read)]) - (let* ([t0 (cpu-time)] - [result (eval expr env)] - [t1 (cpu-time)]) - (repl-print result env cfg) - (display (colored cfg yellow - (format ";; ~a ms~n" (- t1 t0)))))))] + [(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 (repl-doc (string->symbol sym-str))) + (display (colored cfg yellow (repl-doc (string->symbol sym-str)))) (newline))] - [(string=? cmd ",apropos") - (let* ([q (string-trim rest)] - [syms (repl-apropos q env)]) - (if (null? syms) - (display ";; no matches\n") + [(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))) - (display " ")) - (take syms 20)) - (newline))))] + (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 (format "Error: ~a~n" exn))]) + (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)))] + + [(string=? cmd ",trace") + (guard (exn [#t (display-error cfg exn)]) + (let ([sym (string->symbol (string-trim rest))]) + (eval `(trace ,sym) env) + (set! *traced-fns* (cons sym *traced-fns*)) + (display (colored cfg green (format ";; tracing ~a~n" sym)))))] + + [(string=? cmd ",untrace") + (guard (exn [#t (display-error cfg exn)]) + (let ([sym (string->symbol (string-trim rest))]) + (eval `(untrace ,sym) env) + (set! *traced-fns* (filter (lambda (s) (not (eq? s sym))) *traced-fns*)) + (display (colored cfg green (format ";; untraced ~a~n" sym)))))] + + [(string=? cmd ",trace-all") + (if (null? *traced-fns*) + (display ";; no traced functions\n") + (begin + (display ";; traced functions:\n") + (for-each (lambda (s) + (fprintf (current-output-port) " ~a~n" s)) + *traced-fns*)))] + + ;; ---- Performance ---- + [(string=? cmd ",time") + (guard (exn [#t (display-error cfg exn)]) + (let ([expr (with-input-from-string rest read)]) + (let-values ([(result cpu-ms real-ms _s0 _s1) + (time-thunk/detailed (lambda () (eval expr env)))]) + (repl-print result env cfg) + (display (colored cfg yellow + (format ";; cpu: ~ams real: ~ams~n" cpu-ms real-ms))))))] + + [(string=? cmd ",bench") + (guard (exn [#t (display-error cfg exn)]) + (let* ([p (open-input-string rest)] + [expr (read p)] + [n (let ([v (read p)]) (if (eof-object? v) 100 v))]) + (display (colored cfg yellow (format ";; benchmarking ~a iterations...~n" n))) + (flush-output-port (current-output-port)) + (let-values ([(total per-iter iters) + (benchmark-thunk (lambda () (eval expr env)) n)]) + (display (colored cfg yellow + (format ";; total: ~ams per-iteration: ~,3fms (~a iter/s)~n" + total per-iter + (if (> per-iter 0) + (inexact (round (/ 1000.0 per-iter))) + "+inf")))))))] + + [(string=? cmd ",profile") + (guard (exn [#t (display-error cfg exn)]) + (let ([expr (with-input-from-string rest read)]) + (profile-clear) + (let ([result (eval expr env)]) + (repl-print result env cfg) + (display (colored cfg yellow ";; profile dump:\n")) + (profile-dump))))] + + [(string=? cmd ",alloc") + (guard (exn [#t (display-error cfg exn)]) + (let ([expr (with-input-from-string rest read)]) + (collect (collect-maximum-generation)) + (let* ([before (bytes-allocated)] + [result (eval expr env)] + [after (bytes-allocated)] + [delta (- after before)]) + (repl-print result env cfg)