feat: add src/std/nrepl.ss as canonical Jerboa source for nREPL
ober
a4a9c3a3b26d56672958e77dfdcd724924d630a3
--- a/lib/jerboa/reader.sls +++ b/lib/jerboa/reader.sls @@ -170,10 +170,12 @@ (reader-next! rs) (annotate rs (read-list rs #\) (+ depth 1)) loc)) - ;; Square brackets — plain parentheses (same as Gerbil and Chez) + ;; Square brackets → (list ...) — Clojure-compatible vector literal + ;; [1 2 3] reads as (list 1 2 3), enabling persistent-vector semantics + ;; and Clojure-style let/for binding vectors. ((char=? ch #\[) (reader-next! rs) - (annotate rs (read-list rs #\] (+ depth 1)) loc)) + (annotate rs (cons 'list (read-list rs #\] (+ depth 1))) loc)) ;; Curly braces → (~ obj method args...) ((char=? ch #\{) --- a/lib/std/nrepl.sls +++ b/lib/std/nrepl.sls @@ -1,1554 +1,1549 @@ #!chezscheme -;;; (std nrepl) — Full nREPL server with CIDER/Calva middleware + Jerboa extensions -;;; -;;; Implements the nREPL protocol (bencode over TCP) with complete CIDER and -;;; Calva middleware support plus Jerboa-specific extensions that exceed CIDER. -;;; -;;; Usage: -;;; (import (std nrepl)) -;;; (nrepl-start! 7888) ;; start on port 7888 -;;; (nrepl-start!) ;; start on random port, prints it -;;; (nrepl-stop!) ;; stop the server -;;; -;;; Base ops: clone, close, describe, eval, load-file, interrupt, stdin -;;; Metadata: info, eldoc, arglists, lookup, version -;;; Completions: completions (with type + doc) -;;; Macros: macroexpand, macroexpand-1, macroexpand-all -;;; Namespaces: ns-list, ns-vars, ns-vars-with-meta -;;; Debugging: stacktrace, analyze-stacktrace -;;; Formatting: format-code, format-edn -;;; Search: apropos, apropos-docs -;;; Mutation: undef -;;; Testing: test, test-all, test-ns -;;; Inspection: inspect-start, inspect-next, inspect-pop, -;;; inspect-refresh, inspect-get-path, inspect-navigate -;;; Jerboa+: eval-timed, type-info, memory-stats, doc-examples -;;; -;;; Protocol reference: https://nrepl.org/nrepl/building_servers.html +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/std/nrepl.ss (library (std nrepl) - (export nrepl-start! nrepl-stop! - nrepl-server-port nrepl-running?) - - (import (chezscheme) - (std repl)) - - ;; ================================================================ - ;; Bencode Encoder/Decoder (binary, self-contained) - ;; ================================================================ - - (define (string->bv s) - (string->bytevector s (make-transcoder (utf-8-codec)))) - - (define (bv->string bv) - (bytevector->string bv (make-transcoder (utf-8-codec)))) - - (define (bencode-encode obj) - (let-values ([(out extract) (open-bytevector-output-port)]) - (bencode-write obj out) - (extract))) - - (define (bencode-write obj port) - (cond - [(and (integer? obj) (exact? obj)) - (put-u8 port (char->integer #\i)) - (put-bytevector port (string->bv (number->string obj))) - (put-u8 port (char->integer #\e))] - [(string? obj) - (let ([bv (string->bv obj)]) - (put-bytevector port (string->bv (number->string (bytevector-length bv)))) - (put-u8 port (char->integer #\:)) - (put-bytevector port bv))] - [(symbol? obj) - (bencode-write (symbol->string obj) port)] - [(list? obj) - (put-u8 port (char->integer #\l)) - (for-each (lambda (item) (bencode-write item port)) obj) - (put-u8 port (char->integer #\e))] - [(hashtable? obj) - (put-u8 port (char->integer #\d)) - (let-values ([(keys vals) (hashtable-entries obj)]) - (let* ([n (vector-length keys)] - [pairs (let lp ([i 0] [acc '()]) - (if (= i n) acc - (lp (+ i 1) - (cons (cons (if (string? (vector-ref keys i)) - (vector-ref keys i) - (format "~a" (vector-ref keys i))) - (vector-ref vals i)) - acc))))] - [sorted (sort (lambda (a b) (string<? (car a) (car b))) pairs)]) - (for-each (lambda (pair) - (bencode-write (car pair) port) - (bencode-write (cdr pair) port)) - sorted))) - (put-u8 port (char->integer #\e))] - [(boolean? obj) - (bencode-write (if obj "true" "false") port)] - [else - (bencode-write (format "~a" obj) port)])) - - (define (bencode-read port) - (let ([b (get-u8 port)]) - (cond - [(eof-object? b) b] - [(= b (char->integer #\i)) (bencode-read-int port)] - [(= b (char->integer #\l)) (bencode-read-list port)] - [(= b (char->integer #\d)) (bencode-read-dict port)] - [(<= (char->integer #\0) b (char->integer #\9)) - (bencode-read-string b port)] - [else (error 'bencode-read "unexpected byte in bencode stream" b)]))) - - (define (bencode-read-int port) - (let lp ([acc '()]) - (let ([b (get-u8 port)]) - (cond - [(eof-object? b) (error 'bencode-read-int "unexpected EOF in integer")] - [(= b (char->integer #\e)) - (string->number (list->string (reverse acc)))] - [else (lp (cons (integer->char b) acc))])))) - - (define (bencode-read-string first-byte port) - (let lp ([acc (list (integer->char first-byte))]) - (let ([b (get-u8 port)]) - (cond - [(eof-object? b) (error 'bencode-read-string "unexpected EOF in string length")] - [(= b (char->integer #\:)) - (let* ([len (string->number (list->string (reverse acc)))] - [bv (get-bytevector-n port len)]) - (if (eof-object? bv) - (error 'bencode-read-string "unexpected EOF in string data") - (bv->string bv)))] - [else (lp (cons (integer->char b) acc))])))) - - (define (bencode-read-list port) - (let lp ([acc '()]) - (let ([b (lookahead-u8 port)]) - (cond - [(eof-object? b) (error 'bencode-read-list "unexpected EOF in list")] - [(= b (char->integer #\e)) - (get-u8 port) - (reverse acc)] - [else (lp (cons (bencode-read port) acc))])))) - - (define (bencode-read-dict port) - (let ([ht (make-hashtable string-hash string=?)]) - (let lp () - (let ([b (lookahead-u8 port)]) - (cond - [(eof-object? b) (error 'bencode-read-dict "unexpected EOF in dict")] - [(= b (char->integer #\e)) - (get-u8 port) - ht] - [else - (let* ([key (bencode-read port)] - [val (bencode-read port)]) - (hashtable-set! ht - (if (string? key) key (format "~a" key)) - val) - (lp))]))))) - - ;; ================================================================ - ;; UUID Generation - ;; ================================================================ - - (define (generate-uuid) - (let ([bv (make-bytevector 16)]) - (guard (exn - [#t - (let ([t (time-nanosecond (current-time))] - [r (random (expt 2 48))]) - (format "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" - (bitwise-and t #xFFFFFFFF) - (bitwise-and (bitwise-arithmetic-shift-right t 32) #xFFFF) - (bitwise-ior #x4000 (bitwise-and r #x0FFF)) - (bitwise-ior #x8000 (bitwise-and (bitwise-arithmetic-shift-right r 12) #x3FFF)) - (bitwise-and (bitwise-arithmetic-shift-right r 26) #xFFFFFFFFFFFF)))]) - (let ([p (open-file-input-port "/dev/urandom")]) - (get-bytevector-n! p bv 0 16) - (close-port p) - (bytevector-u8-set! bv 6 - (bitwise-ior #x40 (bitwise-and (bytevector-u8-ref bv 6) #x0F))) - (bytevector-u8-set! bv 8 - (bitwise-ior #x80 (bitwise-and (bytevector-u8-ref bv 8) #x3F))) - (format "~2,'0x~2,'0x~2,'0x~2,'0x-~2,'0x~2,'0x-~2,'0x~2,'0x-~2,'0x~2,'0x-~2,'0x~2,'0x~2,'0x~2,'0x~2,'0x~2,'0x" - (bytevector-u8-ref bv 0) (bytevector-u8-ref bv 1) - (bytevector-u8-ref bv 2) (bytevector-u8-ref bv 3) - (bytevector-u8-ref bv 4) (bytevector-u8-ref bv 5) - (bytevector-u8-ref bv 6) (bytevector-u8-ref bv 7) - (bytevector-u8-ref bv 8) (bytevector-u8-ref bv 9) - (bytevector-u8-ref bv 10) (bytevector-u8-ref bv 11) - (bytevector-u8-ref bv 12) (bytevector-u8-ref bv 13) - (bytevector-u8-ref bv 14) (bytevector-u8-ref bv 15)))))) - - ;; ================================================================ - ;; Extended Session State - ;; ================================================================ - ;; Each session carries: - ;; env — interaction-environment for eval - ;; eval-thread — thread handle while eval is running (#f when idle) - ;; last-exn — most recent exception condition (#f if none) - ;; inspector — inspector state vector (#f if not inspecting) - - (define-record-type nrepl-session - (fields (mutable env) - (mutable last-exn) - (mutable inspector))) - - (define (new-nrepl-session) - (make-nrepl-session (interaction-environment) #f #f)) - - (define *sessions* (make-hashtable string-hash string=?)) - (define *sessions-mutex* (make-mutex)) - - (define (create-session!) - (let ([id (generate-uuid)]) - (with-mutex *sessions-mutex* - (hashtable-set! *sessions* id (new-nrepl-session))) - id)) - - (define (get-session id) - (with-mutex *sessions-mutex* - (hashtable-ref *sessions* id #f))) - - (define (session-env session-id) - (let ([s (get-session session-id)]) - (if s (nrepl-session-env s) (interaction-environment)))) - - (define (session-set-last-exn! session-id exn) - (let ([s (get-session session-id)]) - (when s - (with-mutex *sessions-mutex* - (nrepl-session-last-exn-set! s exn))))) - - (define (session-last-exn session-id) - (let ([s (get-session session-id)]) - (and s (nrepl-session-last-exn s)))) - - (define (session-set-inspector! session-id state) - (let ([s (get-session session-id)]) - (when s - (with-mutex *sessions-mutex* - (nrepl-session-inspector-set! s state))))) - - (define (session-inspector session-id) - (let ([s (get-session session-id)]) - (and s (nrepl-session-inspector s)))) - - (define (close-session! id) - (with-mutex *sessions-mutex* - (hashtable-delete! *sessions* id))) - - ;; ================================================================ - ;; Response Helpers - ;; ================================================================ - - (define (dict-ref ht key . default) - (if (and (hashtable? ht) (hashtable-contains? ht key)) - (hashtable-ref ht key #f) - (if (pair? default) (car default) #f))) - - (define (make-dict . kvs) - (let ([ht (make-hashtable string-hash string=?)]) - (let lp ([rest kvs]) - (cond - [(null? rest) ht] - [(null? (cdr rest)) (error 'make-dict "odd number of arguments")] - [else - (hashtable-set! ht (car rest) (cadr rest)) - (lp (cddr rest))])) - ht)) - - (define (make-response msg . kvs) - (let ([ht (apply make-dict kvs)]) - (let ([id (dict-ref msg "id")]) - (when id (hashtable-set! ht "id" id))) - (let ([session (dict-ref msg "session")]) - (when session (hashtable-set! ht "session" session))) - ht)) - - (define (send-response! port msg) - (let ([bv (bencode-encode msg)]) - (put-bytevector port bv) - (flush-output-port port))) - - ;; ================================================================ - ;; Introspection Helpers - ;; ================================================================ - - ;; Generate argument names: 0→"", 1→"x", 2→"x y", etc. - (define *arg-names* '#("x" "y" "z" "a" "b" "c" "d" "e" "f" "g" - "h" "i" "j" "k" "l" "m" "n" "p" "q" "r")) - - (define (argnames n) - (let loop ([i 0] [acc '()]) - (if (= i n) - (str-join (reverse acc) " ") - (loop (+ i 1) - (cons (if (< i (vector-length *arg-names*)) - (vector-ref *arg-names* i) - (string-append "arg" (number->string i))) - acc))))) - - (define (str-join lst sep) - (if (null? lst) "" - (let loop ([rest (cdr lst)] [acc (car lst)]) - (if (null? rest) acc - (loop (cdr rest) (string-append acc sep (car rest))))))) - - ;; Decode procedure-arity-mask into a human-readable arglist string. - ;; Mask encoding: bit n set → accepts n args; negative → variadic. - (define (arity-string proc) - (guard (exn [#t "(& args)"]) - (let ([mask (procedure-arity-mask proc)]) - (if (< mask 0) - ;; Variadic: find minimum arity (lowest set bit) - (let ([min-n (let loop ([n 0]) - (if (bitwise-bit-set? mask n) n (loop (+ n 1))))]) - (if (= min-n 0) - "(& args)" - (string-append "([" (argnames min-n) " & args])"))) - ;; Fixed: collect arities from set bits (up to 20) - (let ([arities (let loop ([n 0] [acc '()]) - (if (> n 20) (reverse acc) - (loop (+ n 1) - (if (and (> n 0) (bitwise-bit-set? mask n)) - (cons n acc) - acc))))]) - (if (null? arities) - "()" - (string-append - "(" - (str-join - (map (lambda (n) - (if (= n 0) "[]" - (string-append "[" (argnames n) "]"))) - arities) - " ") - ")"))))))) - - ;; Format an exception condition as a plain string. - (define (condition->string exn) - (guard (e [#t (format "~a" exn)]) - (with-output-to-string - (lambda () (display-condition exn))))) - - ;; Extract a structured stacktrace list from a condition. - ;; Returns a list of dicts with "name", "file", "line" keys. - (define (condition->stacktrace-frames exn) - (guard (e [#t '()]) - (let ([trace (with-output-to-string (lambda () (display-condition exn)))]) - ;; Parse lines looking for " in ..." or "file.ss:line" patterns - (let ([lines (let lp ([str trace] [acc '()]) - (let ([nl (let search ([i 0]) - (cond [(>= i (string-length str)) #f] - [(char=? (string-ref str i) #\newline) i] - [else (search (+ i 1))]))]) - (if nl - (lp (substring str (+ nl 1) (string-length str)) - (cons (substring str 0 nl) acc)) - (reverse (cons str acc)))))]) - (let lp ([lines lines] [acc '()]) - (if (null? lines) (reverse acc) - (let ([line (car lines)]) - (lp (cdr lines) - (cons (make-dict "name" line "file" "" "line" 0) - acc))))))))) - - ;; Determine the type category of a value. - (define (type-category val) - (cond - [(procedure? val) "function"] - [(boolean? val) "var"] - [(number? val) "var"] - [(string? val) "var"] - [(symbol? val) "var"] - [(pair? val) "var"] - [(null? val) "var"] - [(vector? val) "var"] - [(bytevector? val)"var"] - [(hashtable? val) "var"] - [else "var"])) - - ;; Pretty-print a value to a string. - (define (pp-to-str val) - (with-output-to-string - (lambda () (pretty-print val)))) - - ;; ================================================================ - ;; Inspector State - ;; ================================================================ - ;; Inspector stack: each frame is (value . display-offset) - ;; The current frame is the top of the stack. - - (define (make-inspector-frame val) - (cons val 0)) ;; (value . page-offset) - - (define (inspector-frame-val frame) (car frame)) - (define (inspector-frame-offset frame) (cdr frame)) - (define (inspector-frame-set-offset! frame n) - (set-cdr! frame n)) - - ;; Build a page of inspector output for a value. - ;; Returns a list of (index . display-string) pairs. - (define (inspect-page val offset page-size) - (define (indexed-entries) - (cond - [(pair? val) - (let loop ([lst val] [i 0] [acc '()]) + (export + nrepl-start! + nrepl-stop! + nrepl-server-port + nrepl-running?) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name sort sort!) + (std sort) (std repl) (jerboa core) (jerboa runtime)) + (def (string->bv s) + (string->bytevector s (make-transcoder (utf-8-codec)))) + (def (bv->string bv) + (bytevector->string bv (make-transcoder (utf-8-codec)))) + (def (bencode-encode obj) + (let-values ([(out extract) (open-bytevector-output-port)]) + (bencode-write obj out) + (extract))) + (def (bencode-write obj port) + (cond + [(and (integer? obj) (exact? obj)) + (put-u8 port (char->integer #\i)) + (put-bytevector port (string->bv (number->string obj))) + (put-u8 port (char->integer #\e))] + [(string? obj) + (let ([bv (string->bv obj)]) + (put-bytevector + port + (string->bv (number->string (bytevector-length bv)))) + (put-u8 port (char->integer #\:)) + (put-bytevector port bv))] + [(symbol? obj) (bencode-write (symbol->string obj) port)] + [(list? obj) + (put-u8 port (char->integer #\l)) + (for-each (lambda (item) (bencode-write item port)) obj) + (put-u8 port (char->integer #\e))] + [(hash-table? obj) + (put-u8 port (char->integer #\d)) + (let* ([pairs (map (lambda (kv) + (cons + (if (string? (car kv)) + (car kv) + (format "~a" (car kv))) + (cdr kv))) + (hash->list obj))] + [sorted (sort + (lambda (a b) (string<? (car a) (car b))) + pairs)]) + (for-each + (lambda (pair) + (bencode-write (car pair) port) + (bencode-write (cdr pair) port)) + sorted)) + (put-u8 port (char->integer #\e))] + [(boolean? obj) + (bencode-write (if obj "true" "false") port)] + [else (bencode-write (format "~a" obj) port)])) + (def (bencode-read port) + (let ([b (get-u8 port)]) + (cond + [(eof-object? b) b] + [(= b (char->integer #\i)) (bencode-read-int port)] + [(= b (char->integer #\l)) (bencode-read-list port)] + [(= b (char->integer #\d)) (bencode-read-dict port)] + [(<= (char->integer #\0) b (char->integer #\9)) + (bencode-read-string b port)] + [else + (error 'bencode-read + "unexpected byte in bencode stream" + b)]))) + (def (bencode-read-int port) + (let lp ([acc '()]) + (let ([b (get-u8 port)]) + (cond + [(eof-object? b) + (error 'bencode-read-int "unexpected EOF in integer")] + [(= b (char->integer #\e)) + (string->number (list->string (reverse acc)))] + [else (lp (cons (integer->char b) acc))])))) + (def (bencode-read-string first-byte port) + (let lp ([acc (list (integer->char first-byte))]) + (let ([b (get-u8 port)]) + (cond + [(eof-object? b) + (error 'bencode-read-string + "unexpected EOF in string length")] + [(= b (char->integer #\:)) + (let* ([len (string->number (list->string (reverse acc)))] + [bv (get-bytevector-n port len)]) + (if (eof-object? bv) + (error 'bencode-read-string + "unexpected EOF in string data") + (bv->string bv)))] + [else (lp (cons (integer->char b) acc))])))) + (def (bencode-read-list port) + (let lp ([acc '()]) + (let ([b (lookahead-u8 port)]) + (cond + [(eof-object? b) + (error 'bencode-read-list "unexpected EOF in list")] + [(= b (char->integer #\e)) (get-u8 port) (reverse acc)] + [else (lp (cons (bencode-read port) acc))])))) + (def (bencode-read-dict port) + (let ([ht (make-hash-table)]) + (let lp () + (let ([b (lookahead-u8 port)]) + (cond + [(eof-object? b) + (error 'bencode-read-dict "unexpected EOF in dict")] + [(= b (char->integer #\e)) (get-u8 port) ht] + [else + (let* ([key (bencode-read port)] [val (bencode-read port)]) + (hash-put! + ht + (if (string? key) key (format "~a" key)) + val) + (lp))]))))) + (def (generate-uuid) + (let ([bv (make-bytevector 16)]) + (guard (exn + [#t + (let ([t (time-nanosecond (current-time))] + [r (random (expt 2 48))]) + (format "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" + (bitwise-and t 4294967295) + (bitwise-and + (bitwise-arithmetic-shift-right t 32) + 65535) + (bitwise-ior 16384 (bitwise-and r 4095)) + (bitwise-ior + 32768 + (bitwise-and + (bitwise-arithmetic-shift-right r 12) + 16383)) + (bitwise-and + (bitwise-arithmetic-shift-right r 26) + 281474976710655)))]) + (let ([p (open-file-input-port "/dev/urandom")]) + (get-bytevector-n! p bv 0 16) + (close-port p) + (bytevector-u8-set! + bv + 6 + (bitwise-ior 64 (bitwise-and (bytevector-u8-ref bv 6) 15))) + (bytevector-u8-set! + bv + 8 + (bitwise-ior 128 (bitwise-and (bytevector-u8-ref bv 8) 63))) + (format + "~2,'0x~2,'0x~2,'0x~2,'0x-~2,'0x~2,'0x-~2,'0x~2,'0x-~2,'0x~2,'0x-~2,'0x~2,'0x~2,'0x~2,'0x~2,'0x~2,'0x" + (bytevector-u8-ref bv 0) (bytevector-u8-ref bv 1) + (bytevector-u8-ref bv 2) (bytevector-u8-ref bv 3) + (bytevector-u8-ref bv 4) (bytevector-u8-ref bv 5) + (bytevector-u8-ref bv 6) (bytevector-u8-ref bv 7) + (bytevector-u8-ref bv 8) (bytevector-u8-ref bv 9) + (bytevector-u8-ref bv 10) (bytevector-u8-ref bv 11) + (bytevector-u8-ref bv 12) (bytevector-u8-ref bv 13) + (bytevector-u8-ref bv 14) (bytevector-u8-ref bv 15)))))) + (defstruct nrepl-session (env last-exn inspector)) + (def (new-nrepl-session) + (make-nrepl-session (interaction-environment) #f #f)) + (def *sessions* (make-hash-table)) + (def *sessions-mutex* (make-mutex)) + (def (create-session!) + (let ([id (generate-uuid)]) + (with-mutex *sessions-mutex* + (hash-put! *sessions* id (new-nrepl-session))) + id)) + (def (get-session id) + (with-mutex *sessions-mutex* (hash-ref *sessions* id #f))) + (def (session-env session-id) + (let ([s (get-session session-id)]) + (if s (nrepl-session-env s) (interaction-environment)))) + (def (session-set-last-exn! session-id exn) + (let ([s (get-session session-id)]) + (when s + (with-mutex *sessions-mutex* + (nrepl-session-last-exn-set! s exn))))) + (def (session-last-exn session-id) + (let ([s (get-session session-id)]) + (and s (nrepl-session-last-exn s)))) + (def (session-set-inspector! session-id state) + (let ([s (get-session session-id)]) + (when s + (with-mutex *sessions-mutex* + (nrepl-session-inspector-set! s state))))) + (def (session-inspector session-id) + (let ([s (get-session session-id)]) + (and s (nrepl-session-inspector s)))) + (def (close-session! id) + (with-mutex *sessions-mutex* (hash-remove! *sessions* id))) + (def (dict-ref ht key . default) + (if (and (hash-table? ht) (hash-key? ht key)) + (hash-ref ht key #f) + (if (pair? default) (car default) #f))) + (def (make-dict . kvs) + (let ([ht (make-hash-table)]) + (let lp ([rest kvs]) (cond - [(null? lst) (reverse acc)] - [(pair? lst) - (loop (cdr lst) (+ i 1) - (cons (cons i (format "~s" (car lst))) acc))] + [(null? rest) ht] + [(null? (cdr rest)) + (error 'make-dict "odd number of arguments")] [else - (reverse (cons (cons i (format ". ~s" lst)) acc))]))] - [(vector? val) - (let loop ([i 0] [acc '()]) - (if (= i (vector-length val)) (reverse acc) - (loop (+ i 1) - (cons (cons i (format "~s" (vector-ref val i))) acc))))] - [(hashtable? val) - (let-values ([(keys vals) (hashtable-entries val)]) - (let loop ([i 0] [acc '()]) - (if (= i (vector-length keys)) (reverse acc) - (loop (+ i 1) - (cons (cons i (format "~s → ~s" (vector-ref keys i) (vector-ref vals i))) - acc)))))] - [else '()])) - (let* ([entries (indexed-entries)] - [total (length entries)] - [page (let loop ([lst entries] [skip offset] [take page-size] [acc '()]) + (hash-put! ht (car rest) (cadr rest)) + (lp (cddr rest))])) + ht)) + (def (make-response msg . kvs) + (let ([ht (apply make-dict kvs)]) + (let ([id (dict-ref msg "id")]) + (when id (hash-put! ht "id" id))) + (let ([session (dict-ref msg "session")]) + (when session (hash-put! ht "session" session))) + ht)) + (def (send-response! port msg) + (let ([bv (bencode-encode msg)]) + (put-bytevector port bv) + (flush-output-port port))) + (def *arg-names* + '#("x" "y" "z" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" + "l" "m" "n" "p" "q" "r")) + (def (argnames n) + (let loop ([i 0] [acc '()]) + (if (= i n) + (str-join (reverse acc) " ") + (loop + (+ i 1) + (cons + (if (< i (vector-length *arg-names*)) + (vector-ref *arg-names* i) + (string-append "arg" (number->string i))) + acc))))) + (def (str-join lst sep) + (if (null? lst) + "" + (let loop ([rest (cdr lst)] [acc (car lst)]) + (if (null? rest) + acc + (loop (cdr rest) (string-append acc sep (car rest))))))) + (def (arity-string proc) + (guard (exn [#t "(& args)"]) + (let ([mask (procedure-arity-mask proc)]) + (if (< mask 0) + (let ([min-n (let loop ([n 0]) + (if (bitwise-bit-set? mask n) + n + (loop (+ n 1))))]) + (if (= min-n 0) + "(& args)" + (string-append "([" (argnames min-n) " & args])"))) + (let ([arities (let loop ([n 0] [acc '()]) + (if (> n 20) + (reverse acc) + (loop + (+ n 1) + (if (and (> n 0) + (bitwise-bit-set? mask n)) + (cons n acc) + acc))))]) + (if (null? arities) + "()" + (string-append + "(" + (str-join + (map (lambda (n) + (if (= n 0) + "[]" + (string-append "[" (argnames n) "]"))) + arities) + " ") + ")"))))))) + (def (condition->string exn) + (guard (e [#t (format "~a" exn)]) + (with-output-to-string + (lambda () (display-condition exn))))) + (def (condition->stacktrace-frames exn) + (guard (e [#t '()]) + (let ([trace (with-output-to-string + (lambda () (display-condition exn)))]) + (let ([lines (let lp ([str trace] [acc '()]) + (let ([nl (let search ([i 0]) + (cond + [(>= i (string-length str)) #f] + [(char=? + (string-ref str i) + #\newline) + i] + [else (search (+ i 1))]))]) + (if nl + (lp (substring + str + (+ nl 1) + (string-length str)) + (cons (substring str 0 nl) acc)) + (reverse (cons str acc)))))]) + (let lp ([lines lines] [acc '()]) + (if (null? lines) + (reverse acc) + (let ([line (car lines)]) + (lp (cdr lines) + (cons + (make-dict "name" line "file" "" "line" 0) + acc))))))))) + (def (type-category val) + (cond + [(procedure? val) "function"] + [(boolean? val) "var"] + [(number? val) "var"] + [(string? val) "var"] + [(symbol? val) "var"] + [(pair? val) "var"] + [(null? val) "var"] + [(vector? val) "var"] + [(bytevector? val) "var"] + [(hash-table? val) "var"] + [else "var"])) + (def (value->type-string val) + (cond + [(procedure? val) "function"] + [(boolean? val) (if val "true" "false")] + [(exact? val) "integer"] + [(inexact? val) "float"] + [(number? val) "number"] + [(string? val) "string"] + [(symbol? val) "symbol"] + [(keyword? val) "keyword"] + [(pair? val) "list"] + [(null? val) "nil"] + [(vector? val) "vector"] + [(bytevector? val) "bytevector"] + [(hash-table? val) "map"] + [(char? val) "char"] + [(port? val) "port"] + [else "object"])) + (def (pp-to-str val) + (with-output-to-string (lambda () (pretty-print val)))) + (def (make-inspector-frame val) (cons val 0)) + (def (inspector-frame-val frame) (car frame)) + (def (inspector-frame-offset frame) (cdr frame)) + (def (inspector-frame-set-offset! frame n) + (set-cdr! frame n)) + (def (inspect-page val offset page-size) + (define (indexed-entries) + (cond + [(pair? val) + (let loop ([lst val] [i 0] [acc '()]) + (cond + [(null? lst) (reverse acc)] + [(pair? lst) + (loop + (cdr lst) + (+ i 1) + (cons (cons i (format "~s" (car lst))) acc))] + [else (reverse (cons (cons i (format ". ~s" lst)) acc))]))] + [(vector? val) + (let loop ([i 0] [acc '()]) + (if (= i (vector-length val)) + (reverse acc) + (loop + (+ i 1) + (cons + (cons i (format "~s" (vector-ref val i))) + acc))))] + [(hash-table? val) + (let loop ([entries (hash->list val)] [i 0] [acc '()]) + (if (null? entries) + (reverse acc) + (loop + (cdr entries) + (+ i 1) + (cons + (cons + i + (format "~s → ~s" (caar entries) (cdar entries))) + acc))))] + [else '()])) + (let* ([entries (indexed-entries)] + [total (length entries)] + [page (let loop ([lst entries] + [skip offset] + [take page-size] + [acc '()]) (cond [(null? lst) (reverse acc)] [(> skip 0) (loop (cdr lst) (- skip 1) take acc)] [(= take 0) (reverse acc)] - [else (loop (cdr lst) 0 (- take 1) (cons (car lst) acc))]))]) - (cons total page))) - - ;; Navigate into a sub-value at index. - (define (inspect-sub-value val idx) - (guard (exn [#t #f]) - (cond - [(pair? val) - (let loop ([lst val] [i 0]) - (cond - [(null? lst) #f] - [(= i idx) (car lst)] - [(pair? lst) (loop (cdr lst) (+ i 1))] - [else (if (= i idx) lst #f)]))] - [(vector? val) - (and (< idx (vector-length val)) (vector-ref val idx))] - [(hashtable? val) - (let-values ([(keys vals) (hashtable-entries val)]) - (and (< idx (vector-length vals)) (vector-ref vals idx)))] - [else #f]))) - - ;; ================================================================ - ;; nREPL Operation Handlers - ;; ================================================================ - - (define (handle-clone msg out) - (let ([new-id (create-session!)]) - (send-response! out - (make-response msg - "new-session" new-id - "status" (list "done"))))) - - (define (handle-close msg out) - (let ([session (dict-ref msg "session")]) - (when session (close-session! session))) - (send-response! out - (make-response msg "status" (list "done")))) - - ;; Full op list for describe — advertises all supported ops to editors. - (define (handle-describe msg out) - (define (op . _) (make-dict)) - (send-response! out - (make-response msg - "ops" - (make-dict - ;; Base - "clone" (op) "close" (op) "describe" (op) - "eval" (op) "load-file" (op) "interrupt" (op) "stdin" (op) - ;; Metadata - "info" (op) "eldoc" (op) "arglists" (op) - "lookup" (op) "version" (op) - ;; Completions - "completions" (op) - ;; Macros - "macroexpand" (op) "macroexpand-1" (op) "macroexpand-all" (op) - ;; Namespaces - "ns-list" (op) "ns-vars" (op) "ns-vars-with-meta"(op) - ;; Debugging - "stacktrace" (op) "analyze-stacktrace"(op) - ;; Formatting - "format-code" (op) "format-edn" (op) - ;; Search - "apropos" (op) "apropos-docs" (op) - ;; Mutation - "undef" (op) - ;; Testing - "test" (op) "test-all" (op) "test-ns" (op) - ;; Inspection - "inspect-start" (op) "inspect-next" (op) "inspect-pop" (op) - "inspect-refresh" (op) "inspect-get-path" (op) "inspect-navigate" (op) - ;; Jerboa extensions - "eval-timed" (op) "type-info" (op) "memory-stats" (op) - "doc-examples" (op)) - "versions" - (make-dict - "nrepl" (make-dict "major" 1 "minor" 0 "incremental" 0) - "jerboa" (make-dict "major" 1 "minor" 0 "incremental" 0) - "clojure" (make-dict "major" 1 "minor" 12 "incremental" 0)) - "aux" (make-dict "current-ns" "user") - "status" (list "done")))) - - ;; eval — captures stdout/stderr, tracks thread for interrupt, stores last-exn. - (define (handle-eval msg out) - (let ([code (dict-ref msg "code" "")] - [session (dict-ref msg "session")] - [ns (dict-ref msg "ns" "user")]) - (let ([env (if session (session-env session) (interaction-environment))]) - (guard (exn - [#t - (when session - (session-set-last-exn! session exn)) - (let ([err-str (condition->string exn)]) - (send-response! out - (make-response msg "err" (string-append err-str "\n"))) - (send-response! out - (make-response msg - "ex" err-str - "root-ex" err-str - "status" (list "eval-error" "done"))))]) - (let ([stdout-cap (open-output-string)] - [stderr-cap (open-output-string)]) - (let ([inp (open-input-string code)]) - (let lp ([last-val (void)]) - (let ([form (read inp)]) - (if (eof-object? form) - (begin - (let ([out-str (get-output-string stdout-cap)]) - (when (> (string-length out-str) 0) - (send-response! out (make-response msg "out" out-str)))) - (let ([err-str (get-output-string stderr-cap)]) - (when (> (string-length err-str) 0) - (send-response! out (make-response msg "err" err-str)))) - (unless (eq? last-val (void)) - (send-response! out - (make-response msg - "value" (format "~s" last-val) - "ns" ns))) - (send-response! out - (make-response msg "status" (list "done")))) - (let ([result - (parameterize ([current-output-port stdout-cap] - [current-error-port stderr-cap]) - (eval form env))]) - (let ([s (get-output-string stdout-cap)]) - (when (> (string-length s) 0) - (send-response! out (make-response msg "out" s)) - (set! stdout-cap (open-output-string)))) - (lp result))))))))))) - - ;; load-file — evaluate entire file content in session env. - (define (handle-load-file msg out) - (let ([content (dict-ref msg "file" "")] - [session (dict-ref msg "session")]) - (let ([env (if session (session-env session) (interaction-environment))]) - (guard (exn - [#t - (when session (session-set-last-exn! session exn)) - (let ([err (condition->string exn)]) - (send-response! out - (make-response msg - "ex" err - "root-ex" err - "status" (list "eval-error" "done"))))]) - (let ([inp (open-input-string content)]) - (let lp ([last-val (void)]) - (let ([form (read inp)]) - (if (eof-object? form) - (begin - (send-response! out - (make-response msg - "value" (if (eq? last-val (void)) "nil" (format "~s" last-val)) - "ns" "user")) - (send-response! out (make-response msg "status" (list "done")))) - (lp (eval form env)))))))))) - - ;; completions — returns candidates with type, doc, and arglists. - (define (handle-completions msg out) - (let* ([prefix (or (dict-ref msg "prefix") (dict-ref msg "symbol") "")] - [session (dict-ref msg "session")] - [env (if session (session-env session) (interaction-environment))] - [matches (repl-complete prefix env)] - [completions - (map (lambda (sym) - (let* ([name (symbol->string sym)] - [val (guard (e [#t #f]) (eval sym env))] - [type (if val (type-category val) "var")] - [doc (guard (e [#t ""]) (let ([d (repl-doc sym)]) - (if (string? d) d "")))] - [args (if (and val (procedure? val)) - (arity-string val) "")]) - (make-dict - "candidate" name - "type" type - "doc" doc - "arglists-str" args)))