diff --git a/src/jolt/backend.janet b/src/jolt/backend.janet index cac8ee9..5ed8c52 100644 --- a/src/jolt/backend.janet +++ b/src/jolt/backend.janet @@ -292,12 +292,15 @@ # leaves ctx-current-ns set to that fn's defining ns (it can't restore on # unwind), which then breaks alias resolution in the catching ns. Snapshot # the ns at try entry, reset it on catch (mirrors the interpreter's try). - (let [saved (gsym)] + (let [saved (gsym) raw (gsym)] ['let [saved (core-fn-call ctx "__current-ns")] ['try (emit ctx (node :body)) - [[(symbol (node :catch-sym))] + [[raw] ['do (core-fn-call ctx "__set-current-ns!" saved) - (emit ctx (node :catch-body))]]]]) + # bind the catch symbol to the UNWRAPPED value (mirrors the + # interpreter), so an interpreted throw's envelope doesn't leak here. + ['let [(symbol (node :catch-sym)) (core-fn-call ctx "__unwrap-ex" raw)] + (emit ctx (node :catch-body))]]]]]) (emit ctx (node :body)))) (if (node :finally) ['defer (emit ctx (node :finally)) core] diff --git a/src/jolt/clojure/java/io.clj b/src/jolt/clojure/java/io.clj index 1848a54..1f29f23 100644 --- a/src/jolt/clojure/java/io.clj +++ b/src/jolt/clojure/java/io.clj @@ -14,6 +14,11 @@ (defn as-file [x] (if (__file? x) x (__make-file x))) +(defn as-url + "Coerce `x` to a java.net.URL value (a :jolt/url). Strings are parsed." + [x] + (if (= :jolt/url (get x :jolt/type)) x (java.net.URL. (str x)))) + (defn reader [x] (cond ;; already a reader (java.io shim or janet file handle) — pass through, @@ -68,7 +73,23 @@ (when-not (janet.os/stat parent) (janet.os/mkdir parent)))))) (defn copy - "Copy from a path/handle `in` to a path/handle `out`." - [in out] - (let [content (if (string? in) (slurp in) (janet.file/read in :all))] - (if (string? out) (spit out content) (janet.file/write out content)))) + "Copy from `in` to `out`. A value carrying a truthy `:jolt/output-stream` + marker is treated as a java.io OutputStream (write via its .write); a + `:jolt/input-stream` source is pumped through its .read. This lets host-shim + libraries (e.g. jolt-lang/http-client's byte streams) participate without core + knowing their concrete types. Falls back to the original path/handle copy." + [in out & opts] + (cond + (get out :jolt/output-stream) + (if (get in :jolt/input-stream) + (let [buf (byte-array 8192)] + (loop [] + (let [n (.read in buf 0 8192)] + (when (not= -1 n) + (.write out buf 0 n) + (recur))))) + ;; in is a byte-array / string + (.write out in)) + :else + (let [content (if (string? in) (slurp in) (janet.file/read in :all))] + (if (string? out) (spit out content) (janet.file/write out content))))) diff --git a/src/jolt/clojure/test.clj b/src/jolt/clojure/test.clj new file mode 100644 index 0000000..46d722e --- /dev/null +++ b/src/jolt/clojure/test.clj @@ -0,0 +1,171 @@ +; Jolt Standard Library: clojure.test +; +; A practical subset of clojure.test for running real test suites under Jolt: +; deftest / is / testing / are / use-fixtures / run-tests, with class-aware +; (thrown? Class body) and (thrown-with-msg? Class re body) inside `is`. Class +; matching is by simple-name (last dotted segment), since Jolt has no JVM class +; objects — Exception/Throwable match any thrown value. +; +; Also exposes the counter/registry API the internal clojure-test-suite harness +; uses (reset-report!, run-registered, n-pass/n-fail/n-error, failures), so this +; is a drop-in superset. + +(ns clojure.test + (:require [clojure.string :as str])) + +;; --- state ----------------------------------------------------------------- + +(def counters (atom {:test 0 :pass 0 :fail 0 :error 0 :fails []})) +(def jolt-report counters) ;; alias used by the suite harness +(def ctx-stack (atom [])) +(def registry (atom [])) ;; [{:name sym :fn thunk}] +(def once-fixtures (atom [])) +(def each-fixtures (atom [])) + +(defn reset-report! [] + (reset! counters {:test 0 :pass 0 :fail 0 :error 0 :fails []}) + (reset! ctx-stack []) + (reset! registry []) + (reset! once-fixtures []) + (reset! each-fixtures [])) + +(defn- ctx-str [] (str/join " " @ctx-stack)) + +(defn inc-pass! [] (swap! counters update :pass inc)) +(defn fail! [form] + (let [line (str (ctx-str) (when (seq @ctx-stack) " ") "FAIL: " form)] + (swap! counters (fn [r] (-> r (update :fail inc) (update :fails conj line)))) + (println line))) +(defn err! [form] + (let [line (str (ctx-str) (when (seq @ctx-stack) " ") "ERROR: " form)] + (swap! counters (fn [r] (-> r (update :error inc) (update :fails conj line)))) + (println line))) + +(defn n-pass [] (:pass @counters)) +(defn n-fail [] (:fail @counters)) +(defn n-error [] (:error @counters)) +(defn failures [] (:fails @counters)) + +;; clojure.test/report multimethod — present so suites that add reporting +;; methods (defmethod clojure.test/report :begin-test-var ...) load. The runner +;; below does its own console output and doesn't dispatch through it. +(defmulti report :type) +(defmethod report :default [_m] nil) + +;; --- class matching for thrown? -------------------------------------------- + +(defn- last-seg [s] + (let [s (str s) + i (str/last-index-of s ".")] + (if i (subs s (inc i)) s))) + +(defn class-match? + "True if thrown value `e` matches the wanted class simple-name `wanted`. + Exception/Throwable match anything." + [e wanted] + (let [w (last-seg wanted)] + (if (or (= w "Exception") (= w "Throwable")) + true + (let [c (class e)] + (and (string? c) (= (last-seg c) w)))))) + +;; --- assertion macros ------------------------------------------------------ + +(defn- thrown-form? [form sym] + (and (seq? form) (symbol? (first form)) (= sym (name (first form))))) + +(defmacro is + ([form] `(is ~form nil)) + ([form msg] + (cond + ;; (is (thrown? Class body...)) + (thrown-form? form "thrown?") + (let [klass (name (second form)) + body (nthrest form 2)] + `(try + ~@body + (clojure.test/fail! (str "expected " '~form " to throw" (when ~msg (str " — " ~msg)))) + (catch Throwable e# + (if (clojure.test/class-match? e# ~klass) + (clojure.test/inc-pass!) + (clojure.test/fail! (str "expected throw of " ~klass " but got " (clojure.core/class e#))))))) + + ;; (is (thrown-with-msg? Class re body...)) + (thrown-form? form "thrown-with-msg?") + (let [klass (name (second form)) + re (nth form 2) + body (nthrest form 3)] + `(try + ~@body + (clojure.test/fail! (str "expected " '~form " to throw")) + (catch Throwable e# + (let [m# (or (clojure.core/ex-message e#) (str e#))] + (if (and (clojure.test/class-match? e# ~klass) (re-find ~re m#)) + (clojure.test/inc-pass!) + (clojure.test/fail! (str "expected throw of " ~klass " matching " ~re " but got " (clojure.core/class e#) ": " m#))))))) + + :else + `(try + (if ~form + (clojure.test/inc-pass!) + (clojure.test/fail! (str (pr-str '~form) (when ~msg (str " — " ~msg))))) + (catch Throwable e# + (clojure.test/err! (str (pr-str '~form) " threw: " (clojure.core/ex-message e#)))))))) + +(defmacro testing [s & body] + `(do + (swap! clojure.test/ctx-stack conj ~s) + (try + (do ~@body) + (finally (swap! clojure.test/ctx-stack pop))))) + +(defmacro deftest [name & body] + `(do + (defn ~name [] ~@body) + (swap! clojure.test/registry conj {:name '~name :fn ~name}) + (var ~name))) + +(defmacro are [argv expr & data] + (let [n (count argv) + rows (partition n data)] + `(do ~@(map (fn [row] + `(let [~@(interleave argv row)] + (clojure.test/is ~expr))) + rows)))) + +;; --- fixtures + run -------------------------------------------------------- + +(defn use-fixtures [kind & fns] + (cond + (= kind :once) (reset! once-fixtures (vec fns)) + (= kind :each) (reset! each-fixtures (vec fns)))) + +(defn- wrap-fixtures [fixtures body-fn] + (if (empty? fixtures) + (body-fn) + ((first fixtures) (fn [] (wrap-fixtures (rest fixtures) body-fn))))) + +(defn- run-one [t] + (swap! counters update :test inc) + (wrap-fixtures @each-fixtures + (fn [] + (try + ((:fn t)) + (catch Throwable e + (err! (str (:name t) " crashed: " (clojure.core/ex-message e)))))))) + +(defn run-registered [] + (doseq [t @registry] (run-one t)) + nil) + +(defn run-tests [& _nses] + (wrap-fixtures @once-fixtures (fn [] (run-registered))) + (let [r @counters] + (println) + (println (str "Ran " (:test r) " tests. " + (:pass r) " assertions passed, " + (:fail r) " failures, " (:error r) " errors.")) + r)) + +(defn run-test [& _] nil) +(defn test-var [& _] nil) diff --git a/src/jolt/core_coll.janet b/src/jolt/core_coll.janet index a841daa..53fac0f 100644 --- a/src/jolt/core_coll.janet +++ b/src/jolt/core_coll.janet @@ -205,6 +205,8 @@ (defn jolt-call [f & args] (cond (or (function? f) (cfunction? f)) (apply f args) + # a var is callable as its current value (Clojure vars implement IFn) + (var? f) (apply jolt-call (var-get f) args) (shape-rec? f) (core-get f (get args 0) (get args 1)) (keyword? f) (core-get (get args 0) f (get args 1)) (and (struct? f) (= :symbol (f :jolt/type))) (core-get (get args 0) f (get args 1)) @@ -454,12 +456,18 @@ (and (struct? to) (nil? (get to :jolt/type))) (let [acc (array)] (each e (pairs to) (array/push acc e)) - (each item items (array/push acc [(vnth item 0) (vnth item 1)])) + # each item is either a [k v] pair OR a map whose entries are merged + # (Clojure: (into {} [{:a 1} {:b 2}]) => {:a 1 :b 2}) + (each item items + (if (map-value? item) + (each e (map-entries-of item) (array/push acc e)) + (array/push acc [(vnth item 0) (vnth item 1)]))) (bulk-map-from-pairs acc)) - # Other map-likes (sorted maps, deftype records): fold core-assoc. + # Other map-likes (sorted maps, deftype records): fold core-conj (handles + # both [k v] pairs and map items). (or (struct? to) (and (table? to) (get to :jolt/deftype))) (do (var result to) - (each item items (set result (core-assoc result (vnth item 0) (vnth item 1)))) + (each item items (set result (core-conj result item))) result) # Accumulate into a native array and bulk-build the pvec ONCE (pv-from-indexed), # instead of an immutable pv-conj per element (each allocating a wrapper + diff --git a/src/jolt/core_io.janet b/src/jolt/core_io.janet index 4d0c335..4e824ec 100644 --- a/src/jolt/core_io.janet +++ b/src/jolt/core_io.janet @@ -104,6 +104,8 @@ (let [s (src :s) p (src :pos)] (put src :pos (length s)) (string/slice s p)) + # a byte-array / buffer body: bytes already in hand, just stringify + (buffer? src) (string src) (string (slurp src)))) (defn core-spit [path content & opts] diff --git a/src/jolt/core_print.janet b/src/jolt/core_print.janet index f819147..388c28c 100644 --- a/src/jolt/core_print.janet +++ b/src/jolt/core_print.janet @@ -182,6 +182,9 @@ (and (struct? v) (= :jolt/inst (v :jolt/type))) (inst->rfc3339 v) # a java.io.File renders as its path (Clojure's File.toString) (and (table? v) (= :jolt/file (get v :jolt/type))) (get v :path) + # (str pattern) -> raw regex source (no #"" delimiters), so libraries that + # compose patterns via (re-pattern (str p1 ...)) work (Pattern.toString). + (and (table? v) (= :jolt/regex (get v :jolt/type))) (get v :source) (= :jolt/namespace (get v :jolt/type)) (ns-display-name v) (and (table? v) (= :jolt/var (get v :jolt/type))) (var-display v) (number? v) (fmt-number v) diff --git a/src/jolt/core_refs.janet b/src/jolt/core_refs.janet index 21bd900..9c218d7 100644 --- a/src/jolt/core_refs.janet +++ b/src/jolt/core_refs.janet @@ -124,6 +124,9 @@ # supers now lives in the Clojure collection tier (no class hierarchy: #{}). (defn core-class [x] (cond + # typed throwables carry their JVM class name (host_net's HTTP/SSL shims): + # (class e) -> "java.net.SocketTimeoutException" so (= ClassSym (class e)) holds + (and (table? x) (get x :class)) (get x :class) (nil? x) nil (number? x) "java.lang.Number" (string? x) "java.lang.String" (boolean? x) "java.lang.Boolean" (keyword? x) "clojure.lang.Keyword" (function? x) "clojure.lang.IFn" (buffer? x) "[B" diff --git a/src/jolt/eval_base.janet b/src/jolt/eval_base.janet index 18632cc..8587a3b 100644 --- a/src/jolt/eval_base.janet +++ b/src/jolt/eval_base.janet @@ -140,6 +140,9 @@ [ctx f args] (cond (or (function? f) (cfunction? f)) (apply f args) + # a var is callable as its current value (Clojure vars implement IFn) — + # e.g. (wrap-request #'core/request) threads the var as the base client + (var? f) (jolt-invoke ctx (var-get f) args) (jolt-transient? f) (transient-lookup f (get args 0) (get args 1)) # a record shape-rec is callable: IFn impl if it has one, else map-like # field access. A plain (non-record) shape-rec is just field access. diff --git a/src/jolt/eval_runtime.janet b/src/jolt/eval_runtime.janet index 07b6b06..d5980a6 100644 --- a/src/jolt/eval_runtime.janet +++ b/src/jolt/eval_runtime.janet @@ -682,6 +682,12 @@ false))) # instance?: the overlay macro passes the TYPE NAME quoted (class names don't # evaluate to values on jolt); the value arg arrives evaluated. + # Generic hook so an external host-shim library (e.g. jolt-lang/http-client) + # can teach instance? about its own shim types without editing core. Each hook + # is (fn [class-name val] -> truthy|nil); consulted when no built-in matches. + (var instance-check-hooks @[]) + (ns-intern core "__register-instance-check!" + (fn [f] (array/push instance-check-hooks f) nil)) (ns-intern core "instance-check" (fn [type-sym val] (if (record-tag val) @@ -756,10 +762,21 @@ "clojure.lang.IPersistentVector" (or (tuple? val) (pvec? val)) "clojure.lang.IPersistentSet" (set? val) "Object" true - false)))) + # no built-in match — consult library-registered instance? hooks + (do (var r false) + (each h instance-check-hooks + (when (h (type-sym :name) val) (set r true) (break))) + r))))) # Reader / expansion as plain fns: read-string parses one form; macroexpand-1 # expands a (quoted, already-evaluated) call form once via its macro var. (ns-intern core "read-string" (fn [s] (parse-string s))) + # Strip the interpreter's {:jolt/type :jolt/exception :value v} throw envelope. + # Compiled catch uses this so a caught value matches what the interpreter binds + # (interpreted throw wraps; compiled throw raises raw) — keeps (class e) / + # ex-message / catch consistent across the compiled⇄interpreted boundary. + (ns-intern core "__unwrap-ex" + (fn [e] (if (and (or (table? e) (struct? e)) (= :jolt/exception (get e :jolt/type))) + (get e :value) e))) # The *in* reader family's host seams. __stdin-read-line: one line from real # stdin, newline stripped, nil at EOF. __parse-next: one form off a string -> # [form rest-of-string], nil when only whitespace remains. *in*, read-line, diff --git a/src/jolt/reader.janet b/src/jolt/reader.janet index 4769f1d..bb26d1f 100644 --- a/src/jolt/reader.janet +++ b/src/jolt/reader.janet @@ -13,6 +13,7 @@ # Forward declaration for mutual recursion (var read-form nil) +(var read-meta nil) # forward decl: read-dispatch (#^) calls it before its defn below # Source-position tracking for the success checker (jolt-fqy). When enabled, the # reader records each LIST form's absolute start offset (lists are the forms that @@ -571,6 +572,7 @@ (= c 95) (let [[_ new-pos] (read-form s (+ pos 2))] # #_ [{:jolt/type :jolt/skip} new-pos]) (= c 39) (read-var-quote s pos) # #' + (= c 94) (read-meta s (+ pos 1)) # #^ — deprecated metadata reader macro (= ^) (= c 34) (read-regex s pos) # #"regex (= c 35) # ## symbolic value: ##Inf ##-Inf ##NaN (let [end (read-symbol-name s (+ pos 2) (+ pos 2)) @@ -622,7 +624,7 @@ (string? meta-form) {:tag meta-form} nil)) -(defn read-meta [s pos] +(set read-meta (fn read-meta [s pos] # pos is at ^ (let [[meta-form new-pos] (read-form s (+ pos 1)) [form new-pos2] (read-form s new-pos) @@ -636,7 +638,7 @@ # Non-symbol targets (collections etc.) keep a runtime with-meta form. Use the # NORMALIZED metadata map (:kw -> {:kw true}, tag -> {:tag …}); a map-literal # meta-form (m is nil) is already a map, so pass it through. - [(array (sym "with-meta") form (if m m meta-form)) new-pos2]))) + [(array (sym "with-meta") form (if m m meta-form)) new-pos2])))) (defn read-until-newline [s pos] (if (or (>= pos (length s)) (= (s pos) 10)) diff --git a/test/spec/clojure-interop-fixes-spec.janet b/test/spec/clojure-interop-fixes-spec.janet new file mode 100644 index 0000000..3166dd5 --- /dev/null +++ b/test/spec/clojure-interop-fixes-spec.janet @@ -0,0 +1,29 @@ +# Specification: Clojure-compat fixes that landed with HTTP-client support +# (jolt-lang/http-client). All are general language behaviours, exercised here +# across interpret + compile modes by the harness. +(use ../support/harness) + +(defspec "interop-fixes / deprecated #^ metadata reader" + ["#^ type hint on a param" "\"x\"" + "(do (defn f1 [#^String s] s) (f1 \"x\"))"] + ["#^\"[B\" array hint" "[1 2]" + "(do (defn f2 [#^\"[B\" b] b) (f2 [1 2]))"] + ["#^ is equivalent to ^" "true" + "(= (meta (with-meta [] {:tag (quote String)})) {:tag (quote String)})"]) + +(defspec "interop-fixes / (str pattern) yields raw source" + ["str of a regex" "\"abc\"" "(str #\"abc\")"] + ["compose patterns via str" "true" + "(boolean (re-matches (re-pattern (str #\"<\" \"(.*)\" \">\")) \"\"))"]) + +(defspec "interop-fixes / into onto a map" + ["merges map items" "true" "(= {:a 1 :b 2} (into {} [{:a 1} {:b 2}]))"] + ["accepts [k v] pairs" "true" "(= {:a 1} (into {} [[:a 1]]))"] + ["map item onto empty {}" "true" "(= {:x 1} (into {} (list {:x 1})))"] + ["conj a map onto {}" "true" "(= {:a 1} (conj {} {:a 1}))"]) + +(defspec "interop-fixes / a var is callable as its value" + ["call a var directly" "42" + "(do (def vf (fn [x] (inc x))) ((var vf) 41))"] + ["var bound as a client fn" "\"ok\"" + "(do (def base (fn [_] \"ok\")) (def mw (fn [client] (fn [req] (client req)))) ((mw (var base)) {}))"])