diff --git a/docs/grammar.ebnf b/docs/grammar.ebnf index dffffb1..89044db 100644 --- a/docs/grammar.ebnf +++ b/docs/grammar.ebnf @@ -123,9 +123,12 @@ deref = "@" , form ; (* (deref form) *) metadata = "^" , meta-form , ws , form ; (* attach metadata to form *) meta-form = map | keyword | symbol | string ; (* Normalized like Clojure: a symbol or string is a type hint -> {:tag ...}; - a keyword -> {keyword true}; a map is used as-is. On a symbol the metadata - rides on the symbol (it stays a bare symbol, so a hint like ^String is - transparent in params/lets/bodies); other targets use a runtime with-meta. *) + a keyword -> {keyword true}; a map is used as-is. A keyword/symbol/string + meta-form on a symbol rides ON the symbol (it stays a bare symbol, so a hint + like ^String is transparent in params/lets/bodies). A MAP meta-form routes + through a runtime (with-meta form ...) even on a symbol (jolt-8w2), so a name + with ^{:map} metadata reads as a form, not a bare symbol — def/defn/defmacro/ns + unwrap that to the bare name (and attach the metadata). *) (* -------------------------------------------------------------------------- Dispatch forms — introduced by "#". diff --git a/docs/libraries.md b/docs/libraries.md index 976697e..694e1ef 100644 --- a/docs/libraries.md +++ b/docs/libraries.md @@ -20,3 +20,20 @@ Libraries confirmed to load and pass their conformance checks on Jolt (select/insert/update/delete/joins/:inline), loaded unmodified from git * [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — as [jolt-lang/db](https://github.com/jolt-lang/db)'s `jdbc.core`, reimplemented over janet sqlite3/pq drivers (SQLite + PostgreSQL) +* [next.jdbc](https://github.com/seancorfield/next-jdbc) — a compatibility layer in + [jolt-lang/db](https://github.com/jolt-lang/db) (`next.jdbc`, `next.jdbc.sql`, + `next.jdbc.prepare`, `next.jdbc.transaction`) over `jdbc.core`, for libraries + that target the next.jdbc API +* [tools.logging](https://github.com/clojure/tools.logging) — the real + `clojure.tools.logging` source runs verbatim. jolt provides a native + `clojure.tools.logging.impl` backend (a stderr `LoggerFactory` — the library's + designed extension point, where slf4j/log4j/jul adapters normally plug in) plus + the host shims it needs (`agent`/`send-off`, `clojure.lang.LockingTransaction`, + a `clojure.pprint` subset, `clojure.string/trim-newline`). The level macros, + `logf`/`logp`, `spy`, and `enabled?` all work; output goes to stderr. +* [migratus](https://github.com/yogthos/migratus) — database migrations; loads + unmodified and runs filesystem SQL/EDN migrations against SQLite through the + next.jdbc layer above. `migrate`/`rollback` round-trip end to end. Caveat: + migration ids are 14-digit timestamps, and the janet-lang/sqlite3 driver + currently truncates INTEGER columns to 32 bits, so completion tracking needs + the one-line upstream fix (`sqlite3_column_int64`); ids under 2^31 work as is. diff --git a/jolt-core/clojure/core/00-syntax.clj b/jolt-core/clojure/core/00-syntax.clj index a2ce11e..0e3fc71 100644 --- a/jolt-core/clojure/core/00-syntax.clj +++ b/jolt-core/clojure/core/00-syntax.clj @@ -110,7 +110,12 @@ ;; then. Its body resolves fn/map/reduce/cond at EXPANSION time, by which point all ;; of 00-syntax has loaded, so using them here is fine. (defmacro ns [nm & clauses] - (let [calls (reduce + ;; ^{:map} metadata on the ns name reads as a (with-meta sym {...}) form, not an + ;; annotated symbol (jolt-8w2). Real libraries put :author/:doc there + ;; (clojure.tools.logging), so unwrap to the bare symbol; jolt does not track + ;; namespace metadata, so the map is dropped. + (let [nm (if (and (seq? nm) (= 'with-meta (first nm))) (second nm) nm) + calls (reduce (fn [acc clause] (if (seq? clause) (let [head (first clause) args (rest clause)] @@ -341,10 +346,14 @@ (defmacro defn [fn-name & body] (let [body (if (and (seq body) (string? (first body))) (rest body) body) body (if (and (seq body) (map? (first body)) (not (symbol? (first body)))) - (rest body) body)] + (rest body) body) + ;; ^{:map} metadata on the name reads as a (with-meta sym …) form, not an + ;; annotated symbol (jolt-8w2). def attaches the metadata, but fn needs a + ;; bare symbol, so unwrap it for the fn name. + fn-only-name (if (symbol? fn-name) fn-name (first (rest fn-name)))] ;; pass the name through to fn: the compiled fn's janet name carries it, ;; so stack traces read app.deep/level3 instead of a gensym (jolt-2o7.1) - `(def ~fn-name (fn ~fn-name ~@body)))) + `(def ~fn-name (fn ~fn-only-name ~@body)))) ;; Jolt doesn't enforce privacy, so defn- is just defn (matching how Clojure's own ;; defn- delegates to defn with :private metadata). diff --git a/jolt-core/clojure/core/20-coll.clj b/jolt-core/clojure/core/20-coll.clj index a12835e..881aeee 100644 --- a/jolt-core/clojure/core/20-coll.clj +++ b/jolt-core/clojure/core/20-coll.clj @@ -519,7 +519,11 @@ ;; via the host dir primitives. Paths (strings), not File objects. (Lives below ;; tree-seq: forward references are analysis errors now — jolt-2o7.3.) (defn file-seq [root] - (tree-seq __dir? __list-dir root)) + (if (__file? root) + ;; java.io.File tree: walk via the File method surface so leaves are File + ;; values callers can invoke .isFile/.getName/slurp on (jolt-hjw). + (tree-seq (fn [f] (.isDirectory f)) (fn [f] (seq (.listFiles f))) root) + (tree-seq __dir? __list-dir root))) ;; Canonical flatten via tree-seq: the leaves (non-sequential nodes) in order. ;; Flattens lists too (sequential?), matching Clojure/CLJS. diff --git a/jolt-core/clojure/core/30-macros.clj b/jolt-core/clojure/core/30-macros.clj index db7e113..a786c3b 100644 --- a/jolt-core/clojure/core/30-macros.clj +++ b/jolt-core/clojure/core/30-macros.clj @@ -21,8 +21,15 @@ ;; clojure.core fns) so they compile as plain invokes. name/mm are passed quoted; ;; the dispatch fn, options, and dispatch value evaluate normally, and the method ;; body becomes a compiled (fn …). -(defmacro defmulti [name dispatch & opts] - `(defmulti-setup (quote ~name) ~dispatch ~@opts)) +;; Clojure allows (defmulti name docstring? attr-map? dispatch-fn & options); +;; drop a leading docstring and/or attr-map so the dispatch fn isn't mistaken for +;; one (migratus's multimethods carry docstrings). +(defmacro defmulti [name & args] + (let [args (if (string? (first args)) (rest args) args) + args (if (and (map? (first args)) (not (symbol? (first args)))) (rest args) args) + dispatch (first args) + opts (rest args)] + `(defmulti-setup (quote ~name) ~dispatch ~@opts))) (defmacro defmethod [mm dispatch-val & fn-tail] `(defmethod-setup (quote ~mm) ~dispatch-val (fn ~@fn-tail))) @@ -39,11 +46,14 @@ (defmacro remove-all-methods [mm] `(remove-all-methods-setup (quote ~mm))) +;; methods/get-method take the multimethod VALUE (Clojure semantics); the setup +;; maps it back to its var via the registry, so a bare multifn ref works from a +;; compiled fn in any namespace (jolt multimethod table-visibility fix). (defmacro get-method [mm dval] - `(get-method-setup (quote ~mm) ~dval)) + `(get-method-setup ~mm ~dval)) (defmacro methods [mm] - `(methods-setup (quote ~mm))) + `(methods-setup ~mm)) ;; prefers reads the store off the VAR (the multifn value can't carry it) — ;; same symbol-passing shape as the other multimethod table ops. diff --git a/jolt-core/clojure/core/50-io.clj b/jolt-core/clojure/core/50-io.clj index aceff06..98d9ff9 100644 --- a/jolt-core/clojure/core/50-io.clj +++ b/jolt-core/clojure/core/50-io.clj @@ -177,3 +177,30 @@ (defmethod print-method :jolt/chan [c w] (.write w "#") nil) + +;; Minimal synchronous agent shim. jolt has no thread pool or STM, so this is +;; enough for libraries that hold an agent but don't depend on asynchronous +;; dispatch (e.g. clojure.tools.logging's *logging-agent*, which only sends from +;; within a transaction — never the case here, so it always logs directly). An +;; agent is an atom; send/send-off apply the action immediately. NOT concurrent. +(defn agent + "Creates an agent (an atom on jolt — synchronous, no async dispatch)." + [state & _opts] + (atom state)) + +(defn send-off + "Apply (action state & args) to the agent's state immediately; return the agent." + [a f & args] + (apply swap! a f args) + a) + +(defn send + "Like send-off on jolt (no separate thread pool)." + [a f & args] + (apply swap! a f args) + a) + +(defn agent-error + "jolt agents never enter an error state." + [_a] + nil) diff --git a/jolt-core/jolt/analyzer.clj b/jolt-core/jolt/analyzer.clj index f56ee38..88d99c1 100644 --- a/jolt-core/jolt/analyzer.clj +++ b/jolt-core/jolt/analyzer.clj @@ -182,9 +182,16 @@ (when (< (count items) 3) (uncompilable "def with no init")) (let [nm (form-sym-name name-sym) - cur (compile-ns ctx)] + cur (compile-ns ctx) + ;; (def name docstring value): docstring is form 2, value form 3. + ;; Matches the interpreter; without this the docstring was taken + ;; as the value and the real init dropped (jolt-6ym). + has-doc (and (> (count items) 3) (string? (nth items 2))) + val-form (nth items (if has-doc 3 2)) + base-meta (or (form-sym-meta name-sym) {}) + node-meta (if has-doc (assoc base-meta :doc (nth items 2)) base-meta)] (host-intern! ctx cur nm) - (def-node cur nm (analyze ctx (nth items 2) env) (form-sym-meta name-sym)))) + (def-node cur nm (analyze ctx val-form env) node-meta))) "let*" (let [bvec (vec (form-vec-items (nth items 1))) r (analyze-bindings ctx bvec env)] (let-node (first r) (analyze-seq ctx (drop 2 items) (second r)))) diff --git a/src/jolt/backend.janet b/src/jolt/backend.janet index 91de6d8..d7485fb 100644 --- a/src/jolt/backend.janet +++ b/src/jolt/backend.janet @@ -191,11 +191,25 @@ (tuple/slice (array/concat @[(symbol (node :recur-name))] (map |(emit ctx $) (vview (node :args)))))) +# Var-cell read of a clojure.core fn, as ((in 'cell :root) args...) — the same +# live-root call the :var emit uses, for the ns get/set helpers below. +(defn- core-fn-call [ctx nm & args] + (def cell (cell-for ctx "clojure.core" nm)) + (tuple (tuple 'in (tuple 'quote cell) :root) ;args)) + (defn- emit-try [ctx node] (def core (if (node :catch-sym) - ['try (emit ctx (node :body)) - [[(symbol (node :catch-sym))] (emit ctx (node :catch-body))]] + # Restore current-ns in the catch: a caught throw from an INTERPRETED fn + # 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 (core-fn-call ctx "__current-ns")] + ['try (emit ctx (node :body)) + [[(symbol (node :catch-sym))] + ['do (core-fn-call ctx "__set-current-ns!" saved) + (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 4d180dd..7f87a4c 100644 --- a/src/jolt/clojure/java/io.clj +++ b/src/jolt/clojure/java/io.clj @@ -6,11 +6,13 @@ ; …) won't work, but file/reader/writer/resource/copy/slurp do. (defn file - "A file path. With a parent and child, joins them with '/'." - ([path] (str path)) - ([parent child] (str parent "/" child))) + "A java.io.File. With a parent and child, joins them with '/'. Returns a + :jolt/file value (instance? File true) with the File method surface; str/slurp + and io/reader coerce it back to its path." + ([path] (__make-file path)) + ([parent child] (__make-file parent child))) -(defn as-file [x] (str x)) +(defn as-file [x] (if (__file? x) x (__make-file x))) (defn reader [x] (cond diff --git a/src/jolt/clojure/pprint.clj b/src/jolt/clojure/pprint.clj new file mode 100644 index 0000000..20f4d49 --- /dev/null +++ b/src/jolt/clojure/pprint.clj @@ -0,0 +1,28 @@ +;; clojure.pprint — minimal jolt shim. +;; +;; The real clojure.pprint is a full pretty-printer (thousands of lines of column +;; tracking / dispatch tables). This shim provides just the surface that portable +;; libraries reach for when they "pretty print" a value — notably +;; clojure.tools.logging/spy (pprint + with-pprint-dispatch + code-dispatch). +;; pprint writes the value readably with a trailing newline (no pretty layout); +;; the dispatch vars are recognized but not used for layout. +(ns clojure.pprint) + +(def code-dispatch + "Recognized but not used for layout on jolt." :code-dispatch) +(def simple-dispatch + "Recognized but not used for layout on jolt." :simple-dispatch) + +(def ^:dynamic *print-pprint-dispatch* simple-dispatch) + +(defn pprint + "Print object readably followed by a newline. Writes to *out* (or the given + writer). Not a pretty-printer on jolt — no column-aware layout." + ([object] (prn object)) + ([object writer] (binding [*out* writer] (prn object)))) + +(defmacro with-pprint-dispatch + "Evaluate body with the given pprint dispatch selected. On jolt the dispatch is + recognized but does not affect layout, so this just evaluates body." + [_dispatch & body] + `(do ~@body)) diff --git a/src/jolt/clojure/string.clj b/src/jolt/clojure/string.clj index c435719..807813e 100644 --- a/src/jolt/clojure/string.clj +++ b/src/jolt/clojure/string.clj @@ -135,3 +135,17 @@ (let [c (str ch)] (if (or (= c "\\") (= c "$")) (str "\\" c) c))) (seq replacement)))) + +;; Ported from clojure.string/trim-newline (CharSequence interop replaced with +;; portable count/subs). Removes all trailing \n or \r characters. +(defn trim-newline + "Removes all trailing newline \\n or return \\r characters from + string. Similar to Perl's chomp." + [s] + (loop [index (count s)] + (if (zero? index) + "" + (let [c (subs s (dec index) index)] + (if (or (= c "\n") (= c "\r")) + (recur (dec index)) + (subs s 0 index)))))) diff --git a/src/jolt/clojure/tools/logging.clj b/src/jolt/clojure/tools/logging.clj new file mode 100644 index 0000000..e963f06 --- /dev/null +++ b/src/jolt/clojure/tools/logging.clj @@ -0,0 +1,338 @@ +;;; logging.clj -- delegated logging for Clojure + +;; by Alex Taggart +;; July 27, 2009 + +;; Copyright (c) Alex Taggart, July 2009. All rights reserved. The use +;; and distribution terms for this software are covered by the Eclipse +;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this +;; distribution. By using this software in any fashion, you are +;; agreeing to be bound by the terms of this license. You must not +;; remove this notice, or any other, from this software. +(ns ^{:author "Alex Taggart" + :doc "Logging macros which delegate to a specific logging implementation. + + A logging implementation is selected at runtime when this namespace is first + loaded. For more details, see the documentation for *logger-factory*. + + If you want to test that your code emits specific log messages, see the + clojure.tools.logging.test namespace."} + clojure.tools.logging + (:use + [clojure.string :only [trim-newline]] + [clojure.pprint :only [code-dispatch pprint with-pprint-dispatch]]) + (:require [clojure.tools.logging.impl :as impl])) + +(def ^{:doc + "The default agent used for performing logging when direct logging is + disabled. See log* for details." :dynamic true} + *logging-agent* (agent nil :error-mode :continue)) + +(def ^{:doc + "The set of levels that will require using an agent when logging from within a + running transaction. Defaults to #{:info :warn}. See log* for details." :dynamic true} + *tx-agent-levels* #{:info :warn}) + +(def ^{:doc + "Overrides the default rules for choosing between logging directly or via an + agent. Defaults to nil. See log* for details." :dynamic true} + *force* nil) + +(defn log* + "Attempts to log a message, either directly or via an agent; does not check if + the level is enabled. + + For performance reasons, an agent will only be used when invoked within a + running transaction, and only for logging levels specified by + *tx-agent-levels*. This allows those entries to only be written once the + transaction commits, and are discarded if it is retried or aborted. As + corollary, other levels (e.g., :debug, :error) will be written even from + failed transactions though at the cost of repeat messages during retries. + + One can override the above by setting *force* to :direct or :agent; all + subsequent writes will be direct or via an agent, respectively." + [logger level throwable message] + (if (case *force* + :agent true + :direct false + (and (clojure.lang.LockingTransaction/isRunning) + (*tx-agent-levels* level))) + (send-off *logging-agent* + (fn [_#] (impl/write! logger level throwable message))) + (impl/write! logger level throwable message)) + nil) + +(declare ^{:dynamic true} *logger-factory*) ; default LoggerFactory instance for calling impl/get-logger + +(defmacro log + "Evaluates and logs a message only if the specified level is enabled. See log* + for more details." + ([level message] + `(log ~level nil ~message)) + ([level throwable message] + `(log ~*ns* ~level ~throwable ~message)) + ([logger-ns level throwable message] + `(log *logger-factory* ~logger-ns ~level ~throwable ~message)) + ([logger-factory logger-ns level throwable message] + `(let [logger# (impl/get-logger ~logger-factory ~logger-ns)] + (if (impl/enabled? logger# ~level) + (log* logger# ~level ~throwable ~message))))) + +(defmacro logp + "Logs a message using print style args. Can optionally take a throwable as its + second arg. See level-specific macros, e.g., debug. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([level message & more] [level throwable message & more])} + [level x & more] + (if (or (instance? String x) (nil? more)) ; optimize for common case + `(log ~level (print-str ~x ~@more)) + `(let [logger# (impl/get-logger *logger-factory* ~*ns*)] + (if (impl/enabled? logger# ~level) + (let [x# ~x] + (if (instance? Throwable x#) ; type check only when enabled + (log* logger# ~level x# (print-str ~@more)) + (log* logger# ~level nil (print-str x# ~@more)))))))) + +(defmacro logf + "Logs a message using a format string and args. Can optionally take a + throwable as its second arg. See level-specific macros, e.g., debugf. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([level fmt & fmt-args] [level throwable fmt & fmt-args])} + [level x & more] + (if (or (instance? String x) (nil? more)) ; optimize for common case + `(log ~level (format ~x ~@more)) + `(let [logger# (impl/get-logger *logger-factory* ~*ns*)] + (if (impl/enabled? logger# ~level) + (let [x# ~x] + (if (instance? Throwable x#) ; type check only when enabled + (log* logger# ~level x# (format ~@more)) + (log* logger# ~level nil (format x# ~@more)))))))) + +(defmacro enabled? + "Returns true if the specific logging level is enabled. Use of this macro + should only be necessary if one needs to execute alternate code paths beyond + whether the log should be written to." + ([level] + `(enabled? ~level ~*ns*)) + ([level logger-ns] + `(impl/enabled? (impl/get-logger *logger-factory* ~logger-ns) ~level))) + +(defmacro spy + "Evaluates expr and may write the form and its result to the log. Returns the + result of expr. Defaults to :debug log level." + ([expr] + `(spy :debug ~expr)) + ([level expr] + `(let [a# ~expr] + (log ~level + (let [s# (with-out-str + (with-pprint-dispatch code-dispatch ; need a better way + (pprint '~expr) + (print "=> ") + (pprint a#)))] + (trim-newline s#))) + a#))) + +(defmacro spyf + "Evaluates expr and may write (format fmt result) to the log. Returns the + result of expr. Defaults to :debug log level. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + ([fmt expr] + `(spyf :debug ~fmt ~expr)) + ([level fmt expr] + `(let [a# ~expr] + (log ~level (format ~fmt a#)) + a#))) + +(defn log-stream + "Creates a PrintStream that will output to the log at the specified level." + [level logger-ns] + (let [logger (impl/get-logger *logger-factory* logger-ns)] + (java.io.PrintStream. + (proxy [java.io.ByteArrayOutputStream] [] + (flush [] + ; deal with reflection in proxy-super + (let [^java.io.ByteArrayOutputStream this this] + (proxy-super flush) + (let [message (.trim (.toString this))] + (proxy-super reset) + (if (> (.length message) 0) + (log* logger level nil message)))))) + true))) + +(let [orig (atom nil) ; holds original System.out and System.err + monitor (Object.)] ; sync monitor for calling setOut/setErr + (defn log-capture! + "Captures System.out and System.err, piping all writes of those streams to + the log. If unspecified, levels default to :info and :error, respectively. + The specified logger-ns value will be used to namespace all log entries. + + Note: use with-logs to redirect output of *out* or *err*. + + Warning: if the logging implementation is configured to output to System.out + (as is the default with java.util.logging) then using this function will + result in StackOverflowException when writing to the log." + ; Implementation Notes: + ; - only set orig when nil to preserve original out/err + ; - no enabled? check before making streams since that may change later + ([logger-ns] + (log-capture! logger-ns :info :error)) + ([logger-ns out-level err-level] + (locking monitor + (compare-and-set! orig nil [System/out System/err]) + (System/setOut (log-stream out-level logger-ns)) + (System/setErr (log-stream err-level logger-ns))))) + (defn log-uncapture! + "Restores System.out and System.err to their original values." + [] + (locking monitor + (when-let [[out err :as v] @orig] + (swap! orig (constantly nil)) + (System/setOut out) + (System/setErr err))))) + +(defmacro with-logs + "Evaluates exprs in a context in which *out* and *err* write to the log. The + specified logger-ns value will be used to namespace all log entries. + + By default *out* and *err* write to :info and :error, respectively." + {:arglists '([logger-ns & body] + [[logger-ns out-level err-level] & body])} + [arg & body] + ; Implementation Notes: + ; - no enabled? check before making writers since that may change later + (let [[logger-ns out-level err-level] (if (vector? arg) + arg + [arg :info :error])] + `(binding [*out* (java.io.OutputStreamWriter. + (log-stream ~out-level ~logger-ns)) + *err* (java.io.OutputStreamWriter. + (log-stream ~err-level ~logger-ns))] + ~@body))) + +;; level-specific macros + +(defmacro trace + "Trace level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :trace ~@args)) + +(defmacro debug + "Debug level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :debug ~@args)) + +(defmacro info + "Info level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :info ~@args)) + +(defmacro warn + "Warn level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :warn ~@args)) + +(defmacro error + "Error level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :error ~@args)) + +(defmacro fatal + "Fatal level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :fatal ~@args)) + +(defmacro tracef + "Trace level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :trace ~@args)) + +(defmacro debugf + "Debug level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :debug ~@args)) + +(defmacro infof + "Info level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :info ~@args)) + +(defmacro warnf + "Warn level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :warn ~@args)) + +(defmacro errorf + "Error level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :error ~@args)) + +(defmacro fatalf + "Fatal level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :fatal ~@args)) + +(defn- call-str [str] + (let [fq-sym (symbol str) + ns-str (or (namespace fq-sym) + (throw (RuntimeException. + (format "The value of the clojure.tools.logging.factory system property is not fully-qualified: %s" + (pr-str str))))) + ns-sym (symbol ns-str) + _ (try + (require ns-sym) + (catch Exception ex + (throw (RuntimeException. + (format "Could not resolve namespace for %s. Either it does not exist or it has a (circular) dependency on clojure.tools.logging." + (pr-str str)))))) + fn-sym (symbol (name fq-sym)) + fn-var (ns-resolve ns-sym fn-sym)] + (if fn-var + (fn-var) + (throw (RuntimeException. + (format "Could not resolve var for %s." + (pr-str str))))))) + +(defn- find-factory [] + (if-let [factory-fn-str (System/getProperty "clojure.tools.logging.factory")] + (call-str factory-fn-str) + (impl/find-factory))) + +(def ^:dynamic *logger-factory* + "An instance satisfying the clojure.tools.logging.impl/LoggerFactory protocol, + which allows uniform access to an underlying logging implementation. + + The default value will be obtained by invoking a no-arg function named by the + \"clojure.tools.logging.factory\" system property, or if unset, by invoking + clojure.tools.logging.impl/find-factory. + + After loading, this var can be programmatically changed to a different + LoggerFactory implementation via binding or alter-var-root. + + See the various factory functions in clojure.tools.logger.impl." + (find-factory)) diff --git a/src/jolt/clojure/tools/logging/impl.clj b/src/jolt/clojure/tools/logging/impl.clj new file mode 100644 index 0000000..41efb8a --- /dev/null +++ b/src/jolt/clojure/tools/logging/impl.clj @@ -0,0 +1,50 @@ +;; clojure.tools.logging.impl — jolt shim. +;; +;; The real impl probes slf4j / log4j / log4j2 / commons-logging / java.util.logging +;; via Class/forName and reflection. jolt has no JVM, so find-factory returns a +;; native stderr-backed factory instead. The Logger and LoggerFactory protocols +;; match the real signatures, so consumers (and any custom factory bound through +;; clojure.tools.logging/*logger-factory*) work unchanged. +(ns clojure.tools.logging.impl) + +(defprotocol Logger + (enabled? [logger level]) + (write! [logger level throwable message])) + +(defprotocol LoggerFactory + (name [factory]) + (get-logger [factory logger-ns])) + +;; Minimum level the default jolt stderr logger emits. trace and debug are +;; suppressed by default; bind or alter-var-root this to change the threshold. +(def ^:dynamic *level* :info) + +(def ^:private level-order + {:trace 0 :debug 1 :info 2 :warn 3 :error 4 :fatal 5}) + +;; The protocol method `name` shadows clojure.core/name in this namespace, so a +;; keyword->label uses an explicit table rather than (name level). +(defn- level-str [level] + (case level + :trace "TRACE" :debug "DEBUG" :info "INFO" + :warn "WARN" :error "ERROR" :fatal "FATAL" + (str level))) + +(defn- stderr-logger [logger-ns] + (reify Logger + (enabled? [_ level] + (>= (get level-order level 2) (get level-order *level* 2))) + (write! [_ level throwable message] + (__eprint + (str (level-str level) " " logger-ns " - " message + (when throwable (str " " throwable))))))) + +(def ^:private jolt-stderr-factory + (reify LoggerFactory + (name [_] "jolt/stderr") + (get-logger [_ logger-ns] (stderr-logger (str logger-ns))))) + +(defn find-factory + "jolt has no JVM logging backends; return the native stderr factory." + [] + jolt-stderr-factory) diff --git a/src/jolt/core.janet b/src/jolt/core.janet index 15d5ae6..297178f 100644 --- a/src/jolt/core.janet +++ b/src/jolt/core.janet @@ -541,7 +541,10 @@ result) (do (var result @{}) (when m (each k (keys m) (put result k (get m k)))) (var i 0) (while (< i (length kvs)) (let [k (kvs i) v (kvs (+ i 1))] (put result k v) (+= i 2))) - (if (struct? m) (table/to-struct result) result)))))) + # nil assocs to a fresh immutable map ((assoc nil :a 1) => {:a 1}); a + # raw table here would not count?/seq like a Clojure map (assoc-in into + # an absent key recurses through nil — migratus's migration maps). + (if (or (struct? m) (nil? m)) (table/to-struct result) result)))))) (defn core-dissoc [m & ks] (cond @@ -1656,6 +1659,8 @@ (if (v :ns) (string (v :ns) "/" (v :name)) (v :name)) (and (struct? v) (= :jolt/uuid (v :jolt/type))) (v :str) (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) (= :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) @@ -1724,6 +1729,41 @@ # the __write / __pr-str1 host seams; str-render-one stays for core-str. (defn core-write [s] (prin s) nil) +(defn core-eprint [s] (eprint s) nil) +(defn core-eprintf [fmt & args] (eprintf fmt ;args) nil) + +# next.jdbc host shims (the db library's next.jdbc compat layer builds on these). +# A connection is a tagged table wrapping a jdbc.core conn (:raw) plus clj +# callbacks: :exec runs one SQL string in the transaction (so the janet-side +# Statement.executeBatch can run SQL without a janet->clj call), :close closes +# the underlying conn, :product is the JDBC database product name. instance? +# Connection (evaluator) and the :jolt/jdbc-conn tagged methods (javatime) key +# off this shape. +(defn core-jdbc-wrap-conn [raw exec closef product] + @{:jolt/type :jolt/jdbc-conn :raw raw :exec exec :close closef + :product product :closed @[false]}) +# Robust unwrap: a wrapped conn -> its :raw; anything else passes through (so the +# next.jdbc fns accept either a wrapped conn or a bare jdbc.core conn/spec). +(defn core-jdbc-conn-raw [x] + (if (and (table? x) (= :jolt/jdbc-conn (get x :jolt/type))) (get x :raw) x)) +(defn core-jdbc-make-stmt [w] + # :close lets with-open close the statement (core-close-resource calls :close); + # nothing to release — executeBatch already ran the commands. + @{:jolt/type :jolt/jdbc-stmt :exec (get w :exec) :cmds @[] :close (fn [] nil)}) + +# java.io.File model (jolt-hjw). io/file and (File. …) build a tagged :jolt/file +# value so (instance? File x) works and migratus's File-vs-jar branching takes +# the filesystem path. The File method surface + nio glob live in javatime; here +# are the constructor/predicate builtins and the path coercion str/slurp use. +(defn core-file-path + "The path string of a :jolt/file, or (string x) for anything else." + [x] + (if (and (table? x) (= :jolt/file (get x :jolt/type))) (get x :path) (string x))) +(defn core-make-file [path &opt child] + (def base (core-file-path path)) + @{:jolt/type :jolt/file :path (if child (string base "/" (core-file-path child)) base)}) +(defn core-file? [x] (and (table? x) (= :jolt/file (get x :jolt/type)))) + # newline lives in the Clojure collection tier (core/20-coll.clj). # Clojure 1.11 string->scalar parsers: nil on malformed input, throw on a @@ -1767,6 +1807,7 @@ # bodies, and the jolt Ring adapter hands those over as StringReaders. (defn core-slurp [src & opts] (cond + (core-file? src) (string (slurp (core-file-path src))) (and (table? src) (string? (get src :s)) (number? (get src :pos))) (let [s (src :s) p (src :pos)] (put src :pos (length s)) @@ -1779,7 +1820,7 @@ (when (and (= :append (in opts i)) (in opts (+ i 1))) (set a true)) (+= i 2)) a)) - (def f (file/open path (if append? :a :w))) + (def f (file/open (core-file-path path) (if append? :a :w))) (file/write f (str-render-one content)) (file/close f) nil) @@ -2706,6 +2747,13 @@ "hash-unordered-coll" core-hash-unordered-coll "gensym" gensym "__write" core-write + "__eprint" core-eprint + "__eprintf" core-eprintf + "__jdbc-wrap-conn" core-jdbc-wrap-conn + "__jdbc-conn-raw" core-jdbc-conn-raw + "__jdbc-make-stmt" core-jdbc-make-stmt + "__make-file" core-make-file + "__file?" core-file? "__pr-str1" core-pr-str1 "__make-uuid" make-uuid "compare" core-compare diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index ff68c25..466e502 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -198,7 +198,16 @@ {:jolt/type :symbol :ns (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx)) :name nm})) - form)) + # Alias-qualified (impl/foo): resolve the alias to its target namespace so the + # emitted symbol resolves at the macro's USE site, which has no such alias + # (jolt-9av). Matches Clojure's syntax-quote. A real ns name (not an alias) + # has no entry and is left as written. + (let [cur (ctx-find-ns ctx (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx))) + target (and cur (or (ns-alias-lookup cur (form :ns)) + (ns-import-lookup cur (form :ns))))] + (if target + {:jolt/type :symbol :ns target :name (form :name)} + form)))) (defn- d-realize "Realize a lazy-seq to an array for positional destructuring / splicing; pass @@ -526,7 +535,9 @@ # future doesn't block the parent. (def- thread-statics {"sleep" (fn [ms] (ev/sleep (/ ms 1000)) nil) - "yield" (fn [] (ev/sleep 0) nil)}) + "yield" (fn [] (ev/sleep 0) nil) + "interrupted" (fn [] false) + "currentThread" (fn [] @{:jolt/type :jolt/thread :id "main"})}) # System statics (wall/monotonic clocks — what portable timing code uses). (def- system-statics @@ -583,7 +594,12 @@ (def n (scan-number (string/trim (string s)) (or radix 10))) (if (and n (= n (math/floor n))) n - (error (string "NumberFormatException: For input string: \"" s "\""))))}) + (error (string "NumberFormatException: For input string: \"" s "\"")))) + "valueOf" (fn [s &opt radix] + (def n (scan-number (string/trim (string s)) (or radix 10))) + (if (and n (= n (math/floor n))) + n + (error (string "NumberFormatException: For input string: \"" s "\""))))}) # Pluggable host-class shims (java.time etc. register here at module load): # class-statics: "ClassName" -> {"member" value-or-fn} (Foo/bar resolution) @@ -611,7 +627,11 @@ "StringReader" "java.io.StringReader" "StringWriter" "java.io.StringWriter" "StringBuilder" "java.lang.StringBuilder" "StringTokenizer" "java.util.StringTokenizer" - "Charset" "java.nio.charset.Charset" "Base64" "java.util.Base64"}) + "Charset" "java.nio.charset.Charset" "Base64" "java.util.Base64" + "Exception" "java.lang.Exception" + "IllegalArgumentException" "java.lang.IllegalArgumentException" + "InterruptedException" "java.lang.InterruptedException" + "Throwable" "java.lang.Throwable"}) (defn- class-value-for "The value a class-name symbol evaluates to: its canonical name string." [nm] @@ -698,7 +718,10 @@ "endsWith" (fn [s p] (string/has-suffix? p s)) "contains" (fn [s sub] (not (nil? (string/find (str-needle sub) s)))) "concat" (fn [s o] (string s o)) - "replace" (fn [s a b] (string/replace-all (str-needle a) (str-needle b) s)) + "replace" (fn [s a b] (string/replace-all (str-needle a) (str-needle b) s)) + "replaceAll" (fn [s regex replacement] (re-replace-all (re-pattern regex) s replacement)) + "replaceFirst" (fn [s regex replacement] (re-replace-first (re-pattern regex) s replacement)) + "matches" (fn [s regex] (not (nil? (re-matches (re-pattern regex) s)))) "compareTo" (fn [s o] (cond (< s o) -1 (> s o) 1 0)) "equalsIgnoreCase" (fn [s o] (= (string/ascii-lower s) (string/ascii-lower (string o))))}) @@ -785,7 +808,9 @@ # No implicit Janet fallback (Stage 3): an unresolved # Clojure symbol is an error. Host access is the explicit # janet/ prefix above. - (error (string "Unable to resolve symbol: " name " in this context")))))))))))))))))) + (if (or (in class-ctors name) (get class-canonical-names name)) + (class-value-for name) + (error (string "Unable to resolve symbol: " name " in this context"))))))))))))))))))) (defn- parse-arg-names "Parse a parameter vector, handling & rest args. Returns {:fixed [names...] :rest name-or-nil :all [names...]}" @@ -1201,6 +1226,13 @@ (ns-unmap ns (if (and (struct? sym) (= :symbol (sym :jolt/type))) (sym :name) (string sym)))))) nil) +# Multimethod value -> its var. methods/get-method take the multimethod VALUE +# (Clojure semantics) and recover the var (hence :jolt/methods) through this, +# which works from a compiled fn in any namespace — resolving the symbol at call +# time in the current ns did not (a bare multifn ref in its defining ns saw an +# empty table once defmethods lived in other namespaces; migratus hit this). +(def multi-registry @{}) + (defn defmulti-setup "(defmulti name dispatch & opts) — intern a multimethod var. A fn; name arrives quoted, dispatch + opts (:default key, :hierarchy h) arrive evaluated. The @@ -1296,6 +1328,7 @@ (put v :jolt/dispatch-cache dispatch-cache) (put v :jolt/default default-key) (when hierarchy (put v :jolt/hierarchy hierarchy)) + (put multi-registry mm-fn v) (var-get v)) (defn defmethod-setup @@ -1305,9 +1338,11 @@ [ctx mm-sym dispatch-val impl] (def mm-var (or (resolve-var ctx @{} mm-sym) - (let [ns (ctx-find-ns ctx (ctx-current-ns ctx))] - (def v (ns-intern ns (mm-sym :name) (fn [& args] nil))) + (let [ns (ctx-find-ns ctx (ctx-current-ns ctx)) + stub (fn [& args] nil)] + (def v (ns-intern ns (mm-sym :name) stub)) (put v :jolt/methods @{}) + (put multi-registry stub v) v))) (def methods (or (get mm-var :jolt/methods) (let [m @{}] (put mm-var :jolt/methods m) m))) # nil is a legal dispatch value (ring's body-string keys a method on it); @@ -1339,6 +1374,12 @@ expand to calls of these)." [ctx] (def core (ctx-find-ns ctx "clojure.core")) + # current-ns get/set for compiled code (emit-try restores the ns on a caught + # throw — an interpreted fn that throws leaves ctx-current-ns set to its + # defining ns, since it can't restore on unwind; the interpreted try already + # repairs this, the compiled try did not, leaking the ns past a catch). + (ns-intern core "__current-ns" (fn [] (ctx-current-ns ctx))) + (ns-intern core "__set-current-ns!" (fn [ns-sym] (ctx-set-current-ns ctx ns-sym) nil)) (ns-intern core "protocol-dispatch" (fn [proto-name method-name obj rest-args] (protocol-dispatch-impl ctx proto-name method-name obj rest-args))) @@ -1474,8 +1515,10 @@ found (when auto-create? (def ns (ctx-find-ns ctx (ctx-current-ns ctx))) - (def nv (ns-intern ns (mm-sym :name) (fn [& args] nil))) + (def stub (fn [& args] nil)) + (def nv (ns-intern ns (mm-sym :name) stub)) (put nv :jolt/methods @{}) + (put multi-registry stub nv) nv)))) (def clear-dispatch-cache! (fn [mm-var] (let [dc (get mm-var :jolt/dispatch-cache)] @@ -1514,16 +1557,21 @@ (fn [mm-sym] (def mm-var (mm-var-of mm-sym false)) (or (and mm-var (get mm-var :jolt/prefers)) {}))) + # methods/get-method receive the multimethod VALUE (Clojure semantics): map it + # back to its var via multi-registry. A symbol arg still works (mm-var-of), for + # any caller that passes one. + (def mm-var-of-val (fn [mm] + (if (function? mm) (get multi-registry mm) (mm-var-of mm false)))) (ns-intern core "get-method-setup" - (fn [mm-sym dval] + (fn [mm dval] (def dval (if (nil? dval) :jolt/nil-sentinel dval)) - (def mm-var (mm-var-of mm-sym false)) + (def mm-var (mm-var-of-val mm)) (when mm-var (let [methods (get mm-var :jolt/methods)] (or (get methods dval) (get methods :default)))))) (ns-intern core "methods-setup" - (fn [mm-sym] - (def mm-var (mm-var-of mm-sym false)) + (fn [mm] + (def mm-var (mm-var-of-val mm)) (when mm-var # a jolt map, not the live host table (and phm so vector dispatch # values look up by value, same reason build-eval-map promotes) @@ -1587,6 +1635,15 @@ "DateTimeFormatter" (and (table? val) (= :jolt/dt-formatter (get val :jolt/type))) "URL" (and (table? val) (= :jolt/url (get val :jolt/type))) "java.net.URL" (and (table? val) (= :jolt/url (get val :jolt/type))) + # next.jdbc host shim: a wrapped jdbc.core connection (core.janet). + # migratus's do-commands only runs SQL through its (instance? Connection) + # branch, so the wrapped conn must answer true here. + "Connection" (and (table? val) (= :jolt/jdbc-conn (get val :jolt/type))) + "java.sql.Connection" (and (table? val) (= :jolt/jdbc-conn (get val :jolt/type))) + # java.io.File model (jolt-hjw): io/file and (File. …) build :jolt/file, + # so migratus's (instance? File migration-dir) takes the filesystem path. + "File" (and (table? val) (= :jolt/file (get val :jolt/type))) + "java.io.File" (and (table? val) (= :jolt/file (get val :jolt/type))) # JVM char[] class — (Class/forName "[C"); jolt char arrays are Janet # arrays of char structs "[C" (and (array? val) @@ -1797,28 +1854,59 @@ (put v :dynamic true)) # def returns the var (Clojure semantics); REPL prints #'ns/name v))) - "defmacro" (let [name-sym (in form 1) - rest-form (tuple/slice form 2) - # optional docstring - has-doc? (and (> (length rest-form) 0) (string? (first rest-form))) - args-form (if has-doc? (in rest-form 1) (first rest-form)) - body (tuple/slice rest-form (if has-doc? 2 1)) - param-info (parse-params args-form) - fixed-pats (param-info :fixed) - rest-pat (param-info :rest) + "defmacro" (let [# ^{:map} metadata on the name reads as a (with-meta sym …) + # form (jolt-8w2); unwrap to the bare symbol like def does. + name-sym (unwrap-meta-name (in form 1)) + after-name (tuple/slice form 2) + # Skip an optional leading docstring (string) then an optional + # attr-map (a struct that is not a symbol — a map literal reads + # as a struct), matching defn. Real macros use both, e.g. + # (defmacro info "doc" {:arglists '(...)} [& args] …). + a1 (if (and (> (length after-name) 0) (string? (first after-name))) + (tuple/slice after-name 1) after-name) + after-meta (if (and (> (length a1) 0) + (struct? (first a1)) + (not= :symbol (get (first a1) :jolt/type))) + (tuple/slice a1 1) a1) + # What remains is either a params VECTOR (tuple) + body, or one + # or more arity CLAUSES (each a list, i.e. a janet array). Build + # a uniform arity list [{:params … :body …} …]. + multi? (and (> (length after-meta) 0) (array? (first after-meta))) + arities (if multi? + (map (fn [cl] {:params (first cl) :body (tuple/slice cl 1)}) + after-meta) + @[{:params (first after-meta) :body (tuple/slice after-meta 1)}]) defining-ns (ctx-current-ns ctx)] (def interp-fn (fn [& macro-args] + (def n (length macro-args)) + # Pick the arity: an exact fixed-count match wins; otherwise the + # first variadic arity that accepts n args (Clojure fn dispatch). + (var chosen nil) + (each ar arities + (def pi (parse-params (ar :params))) + (when (and (nil? chosen) (not (pi :rest)) (= n (length (pi :fixed)))) + (set chosen [pi (ar :body)]))) + (when (nil? chosen) + (each ar arities + (def pi (parse-params (ar :params))) + (when (and (nil? chosen) (pi :rest) (>= n (length (pi :fixed)))) + (set chosen [pi (ar :body)])))) + (when (nil? chosen) + (error (string "no matching arity for macro " (name-sym :name) + " (" n " args)"))) + (def pi (chosen 0)) + (def body (chosen 1)) (var new-bindings @{}) (table/setproto new-bindings bindings) (put new-bindings "&env" @{}) # implicit &env for macro bodies (table — nil-safe) (var i 0) # Destructure macro params (like fn), so [& [a & more :as all]] # and {:keys …} rest forms work in macro arglists. - (each pat fixed-pats + (each pat (pi :fixed) (destructure-bind ctx new-bindings pat (macro-args i)) (++ i)) - (when rest-pat - (destructure-bind ctx new-bindings rest-pat (rest-args-val macro-args i))) + (when (pi :rest) + (destructure-bind ctx new-bindings (pi :rest) (rest-args-val macro-args i))) # Use defining namespace for symbol resolution (def saved-ns (ctx-current-ns ctx)) (ctx-set-current-ns ctx defining-ns) @@ -1831,12 +1919,20 @@ (set result (eval-form ctx new-bindings bf))) (ctx-set-current-ns ctx saved-ns) result)) - # Prefer a COMPILED expander (native-speed expansion, zero runtime - # cost). Skip when the body uses &env/&form (the compiled fn has no - # such params) — those fall back to the interpreted closure. - (def uses-env (or (form-uses-sym? body "&env") (form-uses-sym? body "&form"))) + # A COMPILED expander (native-speed) is only built for the + # single-arity case (the compile hook + recompile path take one + # [args body]); multi-arity macros use the interpreted expander. + (def single? (= 1 (length arities))) + (def args-form (and single? ((first arities) :params))) + (def body (and single? ((first arities) :body))) + (def uses-env (do (var u false) + (each ar arities + (when (or (form-uses-sym? (ar :body) "&env") + (form-uses-sym? (ar :body) "&form")) + (set u true))) + u)) (def compiled-fn - (when (and macro-compile-hook (not uses-env)) + (when (and macro-compile-hook single? (not uses-env)) (macro-compile-hook ctx args-form body))) (def macro-fn (or compiled-fn interp-fn)) (let [ns-name (ctx-current-ns ctx) @@ -1847,8 +1943,10 @@ # compile it once the analyzer is alive (staged bootstrap): a # macro defined WHILE the analyzer is still being built gets an # interpreted closure now, a compiled expander later. uses-env - # macros stay interpreted (the compiled fn* has no &env/&form). - (put v :macro-src @[args-form body]) + # macros stay interpreted (the compiled fn* has no &env/&form); + # multi-arity macros keep the interpreted dispatch (no single + # [args body] to recompile). + (when single? (put v :macro-src @[args-form body])) (put v :macro-uses-env uses-env) (when compiled-fn (put v :macro-compiled true)) # A (re)defined macro invalidates any cached expansions. @@ -2065,9 +2163,20 @@ (apply loop-fn args)))) "throw" (let [val (eval-form ctx bindings (in form 1))] (error {:jolt/type :jolt/exception :value val})) - "try" (let [body-form (in form 1) - clauses (tuple/slice form 2) - n (length clauses) + "try" (let [# The body is EVERY form between `try` and the first catch/finally + # clause (not just form 1 — a multi-form body before the clauses, + # e.g. (try (foo) (bar) (catch …)), dropped all but the first). + forms (tuple/slice form 1) + clause? (fn [c] + (and (array? c) (> (length c) 0) + (struct? (first c)) (= :symbol ((first c) :jolt/type)) + (or (= "catch" ((first c) :name)) + (= "finally" ((first c) :name))))) + split (do (var k 0) + (while (and (< k (length forms)) (not (clause? (in forms k)))) (++ k)) + k) + body-forms (tuple/slice forms 0 split) + clauses (tuple/slice forms split) # current-ns is dynamic state. The interpreter rebinds it to a # fn's defining ns while that fn runs and restores it on normal # return, but a fn that THROWS unwinds past its own restore — so @@ -2078,52 +2187,49 @@ (var catch-sym nil) (var catch-body nil) (var finally-body nil) - (var i 0) - (while (< i n) - (let [clause (in clauses i)] - (if (and (array? clause) (> (length clause) 0)) - (let [head (first clause)] - (if (and (struct? head) (= :symbol (head :jolt/type))) - (match (head :name) - "catch" (do - (set catch-sym (in clause 2)) - (set catch-body (tuple/slice clause 3))) - "finally" (set finally-body (tuple/slice clause 1))))))) - (++ i)) - (defn run-finally [f] - (when f - (each fb f (eval-form ctx bindings fb)))) - (if catch-sym - (try - (eval-form ctx bindings body-form) - ([err] - (ctx-set-current-ns ctx try-ns) - (var new-bindings @{}) - (table/setproto new-bindings bindings) - # bind the originally-thrown value (unwrap the :jolt/exception - # envelope) so (catch ... e (throw e)) rethrows the same value - # rather than nesting another envelope - (def caught - (if (and (or (table? err) (struct? err)) (= :jolt/exception (get err :jolt/type))) - (get err :value) - err)) - (put new-bindings (catch-sym :name) caught) - (var result nil) - (each cb catch-body - (set result (eval-form ctx new-bindings cb))) - (run-finally finally-body) - result)) - (if finally-body + (each clause clauses + (when (and (array? clause) (> (length clause) 0)) + (let [head (first clause)] + (when (and (struct? head) (= :symbol (head :jolt/type))) + (match (head :name) + "catch" (do + (set catch-sym (in clause 2)) + (set catch-body (tuple/slice clause 3))) + "finally" (set finally-body (tuple/slice clause 1))))))) + (defn eval-body [] + (var result nil) + (each bf body-forms (set result (eval-form ctx bindings bf))) + result) + (defn run-finally [] + (when finally-body + (each fb finally-body (eval-form ctx bindings fb)))) + (defn run-protected [] + (if catch-sym (try - (do - (def result (eval-form ctx bindings body-form)) - (run-finally finally-body) - result) + (eval-body) ([err] (ctx-set-current-ns ctx try-ns) - (run-finally finally-body) - (error err))) - (eval-form ctx bindings body-form)))) + (var new-bindings @{}) + (table/setproto new-bindings bindings) + # bind the originally-thrown value (unwrap the :jolt/exception + # envelope) so (catch … e (throw e)) rethrows the same value + # rather than nesting another envelope + (def caught + (if (and (or (table? err) (struct? err)) (= :jolt/exception (get err :jolt/type))) + (get err :value) + err)) + (put new-bindings (catch-sym :name) caught) + (var result nil) + (each cb catch-body + (set result (eval-form ctx new-bindings cb))) + result)) + # no catch: restore the ns on an unwinding error, then re-raise + (try (eval-body) ([err] (ctx-set-current-ns ctx try-ns) (error err))))) + # finally ALWAYS runs (success, caught error, or rethrow) — defer so it + # fires even if a catch body throws. Without a finally, just run. + (if finally-body + (defer (run-finally) (run-protected)) + (run-protected))) "set!" (let [target (in form 1) val (eval-form ctx bindings (in form 2))] # Handle (set! (.-field obj) val) — .-field shorthand as a list @@ -2365,8 +2471,11 @@ (if (= :jolt/char (form :jolt/type)) form # a UUID/inst value flowing back through eval (macro expansion, eval of a - # read form) is a self-evaluating literal, like chars. - (if (or (= :jolt/uuid (form :jolt/type)) (= :jolt/inst (form :jolt/type))) + # read form) is a self-evaluating literal, like chars. A namespace object + # does too: `~*ns*` in a syntax-quote (clojure.tools.logging) splices the + # live ns into the expansion. + (if (or (= :jolt/uuid (form :jolt/type)) (= :jolt/inst (form :jolt/type)) + (= :jolt/namespace (form :jolt/type))) form (if (= :jolt/set (form :jolt/type)) # evaluate each element (set literals like #{(inc 1)} must compute) diff --git a/src/jolt/javatime.janet b/src/jolt/javatime.janet index 20f652f..5986d4d 100644 --- a/src/jolt/javatime.janet +++ b/src/jolt/javatime.janet @@ -6,6 +6,7 @@ # install call — adding another java.* shim follows the same shape. (use ./evaluator) +(use ./regex) (import ./phm) (defn- chr [s] (get s 0)) @@ -442,7 +443,217 @@ (or (scan-number (string/trim (string v))) (error (string "NumberFormatException: For input string: \"" v "\"")))))) (each nm ["Locale" "java.util.Locale"] - (register-class-ctor! nm (fn [id &opt _country] @{:jolt/type :jolt/locale :id (string id)})))) + (register-class-ctor! nm (fn [id &opt _country] @{:jolt/type :jolt/locale :id (string id)}))) + # java.util.regex.Pattern statics: Pattern/compile, Pattern/quote, Pattern/MULTILINE. + # Pattern/compile returns jolt's native :jolt/regex compiled value so that + # str/replace, re-matches, .split etc accept it transparently. + (defn- pattern-quote [s] + (def meta "\\.[]{}()*+-?^$|&") + (def buf @"") + (var i 0) + (while (< i (length s)) + (def c (s i)) + (if (string/find (string/from-bytes c) meta) + (buffer/push buf (chr "\\"))) + (buffer/push buf (string/from-bytes c)) + (++ i)) + (string buf)) + (def pattern-multiline 8) + (each nm ["Pattern" "java.util.regex.Pattern"] + (register-class-statics! nm + @{"compile" (fn [s &opt flags] + (if (and flags (= (band flags pattern-multiline) pattern-multiline)) + (re-pattern (string "(?m)" s)) + (re-pattern s))) + "quote" (fn [s] (pattern-quote s)) + "MULTILINE" pattern-multiline})) + # .split on compiled regex values: delegates to re-split, drops trailing empties + (register-tagged-methods! :jolt/regex + @{"split" (fn [self s &opt limit] + (def parts (re-split self s)) + (while (and (> (length parts) 0) (= "" (last parts))) + (array/pop parts)) + parts)}) + # JVM exception constructors: (Exception. msg), (IllegalArgumentException. msg), + # (InterruptedException. msg). Return the message string so getMessage works. + (each nm ["Exception" "java.lang.Exception"] + (register-class-ctor! nm (fn [msg] (string msg)))) + (each nm ["IllegalArgumentException" "java.lang.IllegalArgumentException"] + (register-class-ctor! nm (fn [msg] (string msg)))) + (each nm ["InterruptedException" "java.lang.InterruptedException"] + (register-class-ctor! nm (fn [msg] (string msg)))) + # Character class statics (ASCII — the engine is byte-based). + (register-class-statics! "Character" + @{"isUpperCase" (fn [ch] (and (>= (ch :ch) 65) (<= (ch :ch) 90))) + "isLowerCase" (fn [ch] (and (>= (ch :ch) 97) (<= (ch :ch) 122)))}) + # java.net.URI constructor: stores the spec string, rounds-trips through str. + (each nm ["URI" "java.net.URI"] + (register-class-ctor! nm (fn [spec] (string spec)))) + # java.util.Date: millis-valued instants; no-arg = now. + (defn- make-date [&opt ms] + @{:jolt/type :jolt/date :ms (or ms (math/floor (* 1000 (os/clock :realtime))))}) + (each nm ["Date" "java.util.Date"] + (register-class-ctor! nm make-date)) + (register-tagged-methods! :jolt/date + @{"getTime" (fn [self] (self :ms)) + "toString" (fn [self] (string (self :ms)))}) + # java.util.TimeZone: getTimeZone(id) -> a tz value. + (defn- make-tz [id] @{:jolt/type :jolt/tz :id (string id)}) + (register-class-statics! "TimeZone" + @{"getTimeZone" (fn [id] (make-tz id))}) + (register-class-statics! "java.util.TimeZone" + @{"getTimeZone" (fn [id] (make-tz id))}) + # java.text.SimpleDateFormat: minimal formatter supporting y M d H m s tokens. + (defn- pad2 [n] (if (< n 10) (string "0" n) (string n))) + (defn- sdf-format [pattern ms utc?] + (def d (os/date (math/floor (/ ms 1000)) (not utc?))) + (def out @"") + (var i 0) + (while (< i (length pattern)) + (def c (pattern i)) + (def k (do (var j i) + (while (and (< j (length pattern)) (= (pattern j) c)) (++ j)) + (- j i))) + (cond + (= c (chr "y")) (do (buffer/push out (if (>= k 4) (string (d :year)) (pad2 (mod (d :year) 100)))) (+= i k)) + (= c (chr "M")) (do (buffer/push out (if (= k 1) (string (+ 1 (d :month))) (pad2 (+ 1 (d :month))))) (+= i k)) + (= c (chr "d")) (do (buffer/push out (if (= k 1) (string (+ 1 (d :month-day))) (pad2 (+ 1 (d :month-day))))) (+= i k)) + (= c (chr "H")) (do (buffer/push out (if (= k 1) (string (d :hours)) (pad2 (d :hours)))) (+= i k)) + (= c (chr "m")) (do (buffer/push out (if (= k 1) (string (d :minutes)) (pad2 (d :minutes)))) (+= i k)) + (= c (chr "s")) (do (buffer/push out (if (= k 1) (string (d :seconds)) (pad2 (d :seconds)))) (+= i k)) + (do (buffer/push out (string/from-bytes c)) (++ i)))) + (string out)) + (defn- make-sdf [pattern] + @{:jolt/type :jolt/sdf :pattern pattern :utc true}) + (each nm ["SimpleDateFormat" "java.text.SimpleDateFormat"] + (register-class-ctor! nm make-sdf)) + (register-tagged-methods! :jolt/sdf + @{"setTimeZone" (fn [self tz] + (put self :utc (= "UTC" (get tz :id))) + self) + "format" (fn [self date] + (sdf-format (self :pattern) (date :ms) (self :utc)))}) + # Thread stub: getContextClassLoader returns a stub so migratus jar/create code + # that walks Thread/currentThread doesn't crash. + (register-tagged-methods! :jolt/thread + @{"getContextClassLoader" (fn [self] @{:jolt/type :jolt/classloader})}) + # ClassLoader degrade (jolt-hjw): there is no classpath, so getResource returns + # nil and migratus's find-migration-dir falls through to the filesystem branch + # (resources/). getSystemClassLoader yields the same stub. + (each nm ["ClassLoader" "java.lang.ClassLoader"] + (register-class-statics! nm @{"getSystemClassLoader" (fn [] @{:jolt/type :jolt/classloader})})) + # No STM on jolt: a transaction is never running, so logging libraries that + # gate agent-vs-direct on it (clojure.tools.logging/log*) always log directly. + (register-class-statics! "clojure.lang.LockingTransaction" @{"isRunning" (fn [] false)}) + (register-tagged-methods! :jolt/classloader + @{"getResource" (fn [self path] nil) + "getResources" (fn [self path] nil) + "getResourceAsStream" (fn [self path] nil)}) + # next.jdbc host shims (paired with the __jdbc-* builtins in core.janet and the + # instance? Connection case in evaluator.janet). The wrapped connection carries + # a clj :exec callback (run one SQL string) and a :close callback. + # java.sql.Timestamp: migratus builds (Timestamp. millis) for the applied + # column; represent it as the millis number so it stores and sorts directly. + (each nm ["Timestamp" "java.sql.Timestamp"] + (register-class-ctor! nm (fn [ms] ms))) + (register-tagged-methods! :jolt/jdbc-conn + @{"setAutoCommit" (fn [self _] self) + "isClosed" (fn [self] (get (get self :closed) 0)) + "close" (fn [self] + (unless (get (get self :closed) 0) + ((get self :close)) + (put (get self :closed) 0 true)) + nil) + "getMetaData" (fn [self] @{:jolt/type :jolt/jdbc-meta :product (get self :product)})}) + (register-tagged-methods! :jolt/jdbc-meta + @{"getDatabaseProductName" (fn [self] (get self :product))}) + # Statement batch: addBatch accumulates SQL strings, executeBatch runs each via + # the connection's clj :exec callback (which executes inside the transaction). + (register-tagged-methods! :jolt/jdbc-stmt + @{"addBatch" (fn [self sql] (array/push (get self :cmds) sql) nil) + "executeBatch" (fn [self] + (def out @[]) + (each c (get self :cmds) (array/push out ((get self :exec) c))) + out) + "close" (fn [self] nil)}) + # java.io.File model (jolt-hjw). A :jolt/file carries its path; io/file and the + # File. ctor build it (see core.janet's __make-file). The method surface below + # is backed by os/ and file/. listFiles returns child :jolt/file values so + # file-seq (File-aware) yields :jolt/file leaves migratus can call methods on. + (defn- jfile-path [x] + (if (and (table? x) (= :jolt/file (get x :jolt/type))) (get x :path) (string x))) + (defn- make-jfile [path &opt child] + @{:jolt/type :jolt/file + :path (if child (string (jfile-path path) "/" (jfile-path child)) (jfile-path path))}) + (defn- last-slash [p] + (var idx nil) (var i 0) + (while (< i (length p)) (when (= (p i) 47) (set idx i)) (++ i)) + idx) + (defn- jfile-name [p] + (if-let [i (last-slash p)] (string/slice p (+ i 1)) p)) + (defn- jfile-abs [p] + (if (string/has-prefix? "/" p) p (string (os/cwd) "/" p))) + (each nm ["File" "java.io.File"] + (register-class-ctor! nm make-jfile)) + (register-tagged-methods! :jolt/file + @{"getPath" (fn [self] (get self :path)) + "toString" (fn [self] (get self :path)) + "getName" (fn [self] (jfile-name (get self :path))) + "getParent" (fn [self] (let [p (get self :path)] + (if-let [i (last-slash p)] (string/slice p 0 i) nil))) + "getAbsolutePath" (fn [self] (jfile-abs (get self :path))) + "getCanonicalPath" (fn [self] (jfile-abs (get self :path))) + "getAbsoluteFile" (fn [self] (make-jfile (jfile-abs (get self :path)))) + "exists" (fn [self] (not (nil? (os/stat (get self :path))))) + "isFile" (fn [self] (= :file (os/stat (get self :path) :mode))) + "isDirectory" (fn [self] (= :directory (os/stat (get self :path) :mode))) + "canRead" (fn [self] (not (nil? (os/stat (get self :path))))) + # listFiles: child File values, or nil when not a directory (Clojure null) + "listFiles" (fn [self] + (let [p (get self :path)] + (when (= :directory (os/stat p :mode)) + (map (fn [e] (make-jfile p e)) (os/dir p))))) + "list" (fn [self] + (let [p (get self :path)] + (when (= :directory (os/stat p :mode)) (os/dir p)))) + "toPath" (fn [self] @{:jolt/type :jolt/nio-path :s (get self :path)}) + "toURI" (fn [self] (string "file:" (jfile-abs (get self :path)))) + "toURL" (fn [self] @{:jolt/type :jolt/url :url (string "file:" (jfile-abs (get self :path)))}) + "delete" (fn [self] (let [r (protect (os/rm (get self :path)))] (truthy? (r 0)))) + "mkdir" (fn [self] (truthy? ((protect (os/mkdir (get self :path))) 0))) + "mkdirs" (fn [self] (truthy? ((protect (os/mkdir (get self :path))) 0))) + "createNewFile" (fn [self] + (let [p (get self :path)] + (if (os/stat p) false + (do (def f (file/open p :w)) (file/close f) true)))) + "equals" (fn [self o] (and (table? o) (= (get self :path) (get o :path)))) + "hashCode" (fn [self] (hash (get self :path)))}) + # java.nio.file degrade for migratus's script-excluded? glob check: just enough + # of Path / FileSystem / PathMatcher to match a filename against a glob, with a + # simple recursive * / ? matcher (no path-segment semantics — filenames only). + (defn- glob-matches? [glob s] + (defn m [gi si] + (cond + (= gi (length glob)) (= si (length s)) + (= (glob gi) 42) # * + (or (m (+ gi 1) si) + (and (< si (length s)) (m gi (+ si 1)))) + (and (< si (length s)) + (or (= (glob gi) 63) (= (glob gi) (s si)))) # ? or literal + (m (+ gi 1) (+ si 1)) + false)) + (m 0 0)) + (register-tagged-methods! :jolt/nio-path + @{"getFileSystem" (fn [self] @{:jolt/type :jolt/nio-fs}) + "toString" (fn [self] (get self :s))}) + (register-tagged-methods! :jolt/nio-fs + @{"getPath" (fn [self s & _] @{:jolt/type :jolt/nio-path :s s}) + "getPathMatcher" (fn [self spec] + @{:jolt/type :jolt/nio-matcher + :glob (if (string/has-prefix? "glob:" spec) + (string/slice spec 5) spec)})}) + (register-tagged-methods! :jolt/nio-matcher + @{"matches" (fn [self path] (glob-matches? (get self :glob) (get path :s)))})) (install!) (install-io!) diff --git a/src/jolt/regex.janet b/src/jolt/regex.janet index 7180c14..f7e4862 100644 --- a/src/jolt/regex.janet +++ b/src/jolt/regex.janet @@ -144,23 +144,29 @@ (let [inner (parse-alt st)] (+= (st :pos) 1) {:op :look :neg false :item inner})) (= k (chr "!")) (do (+= (st :pos) 3) (let [inner (parse-alt st)] (+= (st :pos) 1) {:op :look :neg true :item inner})) - # inline flags (?i) / (?i:...) — set case-insensitive + # inline flags (?i) / (?m) / (?im:...) etc. (do (var j (+ (st :pos) 2)) (var seti false) + (var setm false) (while (and (< j (length s)) (not= (s j) (chr ")")) (not= (s j) (chr ":"))) (when (= (s j) (chr "i")) (set seti true)) + (when (= (s j) (chr "m")) (set setm true)) (++ j)) (if (= (s j) (chr ":")) (do (set (st :pos) (+ j 1)) - (def saved (st :ci)) + (def savedci (st :ci)) + (def savedml (st :ml)) (when seti (set (st :ci) true)) + (when setm (set (st :ml) true)) (def inner (parse-alt st)) - (set (st :ci) saved) + (set (st :ci) savedci) + (set (st :ml) savedml) (+= (st :pos) 1) {:op :ncgroup :item inner}) - (do (set (st :pos) (+ j 1)) # (?i) — flag for rest of pattern + (do (set (st :pos) (+ j 1)) # (?i) / (?m) — flag for rest of pattern (when seti (set (st :ci) true)) + (when setm (set (st :ml) true)) {:op :seq :items @[]}))))) # capturing group (let [n (++ (st :ngroup))] @@ -235,9 +241,9 @@ (if (= 1 (length branches)) (branches 0) {:op :alt :items branches}))) (defn- parse [source] - (def st @{:s source :pos 0 :ngroup 0 :ci false :dotall false}) + (def st @{:s source :pos 0 :ngroup 0 :ci false :ml false :dotall false}) (def ast (parse-alt st)) - [ast (st :ngroup)]) + [ast (st :ngroup) (st :ml)]) # ============================================================ # Emit: AST -> PEG grammar (continuation passing) @@ -250,7 +256,7 @@ ~(set ,(string/from-bytes (lower-b b) (upper-b b))) ~(set ,(string/from-bytes b)))) -(defn- make-emitter [grammar] +(defn- make-emitter [grammar ml] (var ctr 0) (defn fresh [] (++ ctr) (keyword (string "r" ctr))) (var emit nil) @@ -304,8 +310,12 @@ ~(sequence (not ,(emit (ast :item) 0)) ,k) ~(sequence (not (not ,(emit (ast :item) 0))) ,k)) :anchor (case (ast :kind) - :start ~(sequence (not (look -1 1)) ,k) - :end ~(sequence (not 1) ,k) + :start (if ml + ~(sequence (choice (not (look -1 1)) (look -1 "\n")) ,k) + ~(sequence (not (look -1 1)) ,k)) + :end (if ml + ~(sequence (choice (not 1) (not (not "\n"))) ,k) + ~(sequence (not 1) ,k)) :wordb ~(sequence (choice (sequence (look -1 ,word-frag) (not ,word-frag)) (sequence (not (look -1 ,word-frag)) (not (not ,word-frag)))) ,k) @@ -317,9 +327,9 @@ emit) (defn compile-regex [source] - (def [ast ngroups] (parse source)) + (def [ast ngroups ml] (parse source)) (def grammar @{}) - (def emit (make-emitter grammar)) + (def emit (make-emitter grammar ml)) # group 0 = whole match: mark start, body, mark end (def body (emit ast ~(sequence (/ (position) ,(fn [p] [0 :e p])) 0))) (put grammar :main ~(sequence (/ (position) ,(fn [p] [0 :s p])) ,body)) diff --git a/test/integration/conformance-test.janet b/test/integration/conformance-test.janet index c5fbb7d..2dee3aa 100644 --- a/test/integration/conformance-test.janet +++ b/test/integration/conformance-test.janet @@ -462,6 +462,58 @@ ["not-any?" "true" "(not-any? even? [1 3 5])"] ["take-last" "[3 4]" "(take-last 2 [1 2 3 4])"] ["replace nil val" "[1 nil 3]" "(replace {2 nil} [1 2 3])"] + + ### ---- migratus enablement: def/defmacro/defmulti forms, assoc, try, ns ---- + # (def name docstring value): the value is the 3rd form, not the docstring + # (jolt-6ym — the analyzer used to bind the docstring as the value). + ["def 3-arg docstring" "42" "(do (def dd \"the doc\" 42) dd)"] + ["def docstring value type" "true" "(do (def ds \"doc\" [1 2]) (vector? ds))"] + # ^{:map} metadata on a def/defn name reads as a with-meta form (jolt-8w2); + # def/defn/defmacro unwrap it instead of choking. + ["def ^{:map} name" "5" "(do (def ^{:private true} mmv 5) mmv)"] + ["defn ^{:map} name" "25" "(do (defn ^{:private true} sqf [x] (* x x)) (sqf 5))"] + # defmacro arity-clause form (jolt-whp) and a leading docstring (with-store shape) + ["defmacro arity-clause" "10" "(do (defmacro m2c ([x] (list (quote *) x 2))) (m2c 5))"] + ["defmacro doc + arity" "30" "(do (defmacro m3c \"doc\" ([x] (list (quote *) x 3))) (* (m3c 5) 2))"] + # defmulti drops a leading docstring (jolt-es4 — it used to be the dispatch fn) + ["defmulti docstring" "\"A\"" "(do (defmulti gmm \"the doc\" identity) (defmethod gmm :a [_] \"A\") (gmm :a))"] + # (assoc nil k v) yields a real map (jolt-w4s); assoc-in nests real maps + ["assoc nil is a map" "1" "(count (assoc nil :a 1))"] + ["assoc-in nested is a map" "1" "(count (:a (assoc-in {} [:a :b] 1)))"] + ["assoc-in deep get" "9" "(get-in (assoc-in {} [:a :b :c] 9) [:a :b :c])"] + # try: a multi-form body and finally that runs on the SUCCESS path with a + # catch present (jolt-0z9 — body forms past the first were dropped and + # finally was skipped on success). + ["try multi-body last" "3" "(try 1 2 3 (catch :default e 0))"] + ["try finally on ok+catch" "9" "(let [a (atom 0)] (try 1 2 (catch :default e :c) (finally (reset! a 9))) @a)"] + ["try finally on throw" "9" "(let [a (atom 0)] (try (throw (ex-info \"x\" {})) (catch :default e nil) (finally (reset! a 9))) @a)"] + # current-ns is restored after a caught throw (jolt-96m): the alias/ns seen by + # code after the catch is the one at the catch site, not the thrower's. + ["ns restored after catch" "\"user\"" + "(do (ns cf.boom) (defn bz [] (throw (Exception. \"e\"))) (in-ns (quote user)) (try (cf.boom/bz) (catch :default e nil)) (str *ns*))"] + # methods sees cross-ns defmethods through a bare multifn ref in its defining + # ns (jolt-9pu — it used to see an empty table). + ["cross-ns methods visible" "[:sql]" + "(do (ns cf.mm) (defmulti ext identity) (defmethod ext :default [_] :d) (defn allk [] (vec (for [[k v] (methods ext) :when (not= k :default)] k))) (ns cf.mmi) (defmethod cf.mm/ext :sql [_] :s) (in-ns (quote user)) (cf.mm/allk))"] + + ### ---- defmacro surface + syntax-quote/ns (enabling real clojure libs) ---- + # multi-arity defmacro (clojure.tools.logging/log has 4 arities) + ["defmacro multi-arity" "[6 5 6]" + "(do (defmacro mar ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b)) ([a b c] (list (quote +) a b c))) [(mar 5) (mar 2 3) (mar 1 2 3)])"] + # defmacro with docstring AND attr-map before the params (every tools.logging + # level macro is shaped this way) + ["defmacro doc + attr-map" "10" + "(do (defmacro mam \"doc\" {:arglists (quote ([x]))} [x] (list (quote inc) x)) (mam 9))"] + # syntax-quote resolves a namespace ALIAS to its target ns, so a macro's + # template resolves at the USE site (jolt-9av) + ["syntax-quote resolves alias" "\"HI\"" + "(do (ns sq.lib (:require [clojure.string :as s])) (defmacro up [x] `(s/upper-case ~x)) (in-ns (quote user)) (sq.lib/up \"hi\"))"] + # ^{:map} metadata on an ns name (jolt-8w2): the ns name is the bare symbol + ["ns name with ^{:map} meta" "5" + "(do (ns ^{:author \"a\" :doc \"d\"} nm.meta) (def q 5) (in-ns (quote user)) nm.meta/q)"] + # ~*ns* splices the live namespace object into a template (it self-evaluates) + ["unquote *ns* in template" "true" + "(do (defmacro cur-ns [] `(str ~*ns*)) (string? (cur-ns)))"] ]) # Run every case under a given context factory and return the failures. The same diff --git a/test/integration/fallback-zero-test.janet b/test/integration/fallback-zero-test.janet index 3095c58..862833f 100644 --- a/test/integration/fallback-zero-test.janet +++ b/test/integration/fallback-zero-test.janet @@ -67,7 +67,10 @@ "(refer (quote clojure.string))" # Stage 2 tier 6c: dispatch-table ops + misc compile as macros/plain invokes "(prefer-method mf :a :b)" "(remove-method mf :a)" "(remove-all-methods mf)" - "(get-method mf :a)" "(methods mf)" + # get-method/methods take the multimethod VALUE (Clojure semantics), so the + # arg must resolve — use a real multifn (print-method) rather than the + # never-defined mf the isolated analyzer can't resolve. + "(get-method print-method :default)" "(methods print-method)" "(satisfies? P 5)" "(instance? String \"x\")" "(locking :x 1)" "(defonce fz-once 1)" "(read-string \"[1 2]\")" "(macroexpand-1 (quote (when true 1)))"]) diff --git a/test/spec/host-interop-spec.janet b/test/spec/host-interop-spec.janet index a0386c8..19f8c04 100644 --- a/test/spec/host-interop-spec.janet +++ b/test/spec/host-interop-spec.janet @@ -223,3 +223,70 @@ "(do (def prev (__reader-features)) (__reader-features-set! [\"clj\" \"jolt\" \"default\"]) (def r (contains? (set (__reader-features)) \"clj\")) (__reader-features-set! prev) r)"] ["restore returns to default" "false" "(do (def prev (__reader-features)) (__reader-features-set! [\"clj\"]) (__reader-features-set! prev) (contains? (set (__reader-features)) \"clj\"))"]) + +# JVM class shims migratus relies on. Exception constructors resolve as bare +# class symbols (jolt-6xk) and carry a message; Character/Thread/Long statics; +# java.sql.Timestamp is the millis number; SimpleDateFormat formats UTC. +(defspec "host-interop / migratus class shims" + ["Exception. message" "\"boom\"" + "(try (throw (Exception. \"boom\")) (catch Throwable e (.getMessage e)))"] + ["IllegalArgumentException." "\"bad\"" + "(try (throw (IllegalArgumentException. \"bad\")) (catch Exception e (.getMessage e)))"] + ["InterruptedException." "\"stop\"" + "(try (throw (InterruptedException. \"stop\")) (catch Throwable e (.getMessage e)))"] + ["Character/isUpperCase" "true" "(Character/isUpperCase \\A)"] + ["Character/isLowerCase" "true" "(Character/isLowerCase \\a)"] + ["Character/isUpperCase neg" "false" "(Character/isUpperCase \\a)"] + ["Thread/interrupted" "false" "(Thread/interrupted)"] + ["Long/valueOf" "42" "(Long/valueOf \"42\")"] + ["Timestamp is millis" "1000" "(.getTime (java.util.Date. (java.sql.Timestamp. 1000)))"] + ["SimpleDateFormat UTC" "\"19700101000000\"" + "(let [f (doto (java.text.SimpleDateFormat. \"yyyyMMddHHmmss\") (.setTimeZone (java.util.TimeZone/getTimeZone \"UTC\")))] (.format f (java.util.Date. 0)))"]) + +# java.io.File model (jolt-hjw): io/file builds a value that answers +# (instance? File _) so migratus's File-vs-jar branch takes the filesystem path; +# the method surface and a File-aware file-seq back it; str/slurp coerce to path. +(defspec "host-interop / java.io.File" + ["instance? File" "true" "(do (require '[clojure.java.io :as io]) (instance? java.io.File (io/file \"/a/b\")))"] + ["str is the path" "\"/a/b\"" "(do (require '[clojure.java.io :as io]) (str (io/file \"/a/b\")))"] + ["getName" "\"c.txt\"" "(do (require '[clojure.java.io :as io]) (.getName (io/file \"/a/b/c.txt\")))"] + ["getPath joins" "\"/a/b\"" "(do (require '[clojure.java.io :as io]) (.getPath (io/file \"/a\" \"b\")))"] + ["isDirectory of repo dir" "true" "(do (require '[clojure.java.io :as io]) (.isDirectory (io/file \"docs\")))"] + ["isFile of repo file" "true" "(do (require '[clojure.java.io :as io]) (.isFile (io/file \"project.janet\")))"] + ["exists is false off-disk" "false" "(do (require '[clojure.java.io :as io]) (.exists (io/file \"/no/such/path/xyz\")))"] + ["file-seq yields File values" "true" + "(do (require '[clojure.java.io :as io]) (every? (fn [f] (instance? java.io.File f)) (file-seq (io/file \"docs\"))))"] + ["file-seq finds files" "true" + "(do (require '[clojure.java.io :as io]) (pos? (count (filter (fn [f] (.isFile f)) (file-seq (io/file \"docs\"))))))"]) + +# The REAL clojure.tools.logging (vendored verbatim) runs on jolt: a jolt +# clojure.tools.logging.impl backend (stderr LoggerFactory) plus host shims +# (agent/send-off, clojure.lang.LockingTransaction/isRunning, a clojure.pprint +# subset, clojure.string/trim-newline) and the defmacro/syntax-quote/ns fixes. +# These cases assert the public API behaves; the level rows return nil because +# the real level macros return the (nil) result of log* when enabled. +(defspec "host-interop / clojure.tools.logging" + ["info returns nil" "nil" "(do (require '[clojure.tools.logging :as log]) (log/info \"hi\" 42))"] + ["debug suppressed" "nil" "(do (require '[clojure.tools.logging :as log]) (log/debug \"x\"))"] + ["debug skips args" "0" "(do (require '[clojure.tools.logging :as log]) (let [a (atom 0)] (log/debug (reset! a 9)) @a))"] + ["enabled? info" "true" "(do (require '[clojure.tools.logging :as log]) (log/enabled? :info))"] + ["enabled? debug" "false" "(do (require '[clojure.tools.logging :as log]) (log/enabled? :debug))"] + ["spy returns value" "3" "(do (require '[clojure.tools.logging :as log]) (log/spy :info (+ 1 2)))"] + ["impl factory name" "\"jolt/stderr\"" + "(do (require '[clojure.tools.logging.impl :as impl]) (impl/name (impl/find-factory)))"] + # vars that exist only in the real library (not in a hand-rolled shim) + ["real lib *tx-agent-levels*" "#{:info :warn}" + "(do (require '[clojure.tools.logging :as log]) log/*tx-agent-levels*)"] + ["real lib log-capture! present" "true" + "(do (require '[clojure.tools.logging :as log]) (fn? log/log-capture!))"] + ["real lib spyf present" "true" + "(do (require '[clojure.tools.logging :as log]) (boolean (resolve 'log/spyf)))"]) + +# Host shims that let the real clojure.tools.logging load: no STM (a transaction +# is never running) and a minimal clojure.pprint (used by spy). +(defspec "host-interop / logging host shims" + ["LockingTransaction/isRunning" "false" "(clojure.lang.LockingTransaction/isRunning)"] + ["pprint writes value" "\"[1 2 3]\\n\"" + "(do (require '[clojure.pprint :as pp]) (with-out-str (pp/pprint [1 2 3])))"] + ["with-pprint-dispatch runs body" "42" + "(do (require '[clojure.pprint :as pp]) (pp/with-pprint-dispatch pp/code-dispatch 42))"]) diff --git a/test/spec/macros-spec.janet b/test/spec/macros-spec.janet index e8d9c60..eb35387 100644 --- a/test/spec/macros-spec.janet +++ b/test/spec/macros-spec.janet @@ -85,3 +85,24 @@ ["with-redefs-fn" "42" "(do (defn wr-i [] 1) (with-redefs-fn {(var wr-i) (fn [] 42)} (fn [] (wr-i))))"] ["macroexpand full" "true" "(let [e (macroexpand (quote (when-not false 1)))] (= (quote if) (first e)))"] ["macroexpand non-macro" "[1 2]" "(macroexpand (quote [1 2]))"]) + +# defmacro accepts the arity-clause form (defmacro name ([params] body...)), a +# leading docstring, and ^{:map} metadata on the name (jolt-whp, jolt-8w2). +(defspec "macros / defmacro arity-clause & name metadata" + ["arity-clause form" "10" "(do (defmacro tw ([x] (list (quote *) x 2))) (tw 5))"] + ["docstring + arity" "15" "(do (defmacro th \"triple\" ([x] (list (quote *) x 3))) (th 5))"] + ["^{:map} name meta" "7" "(do (defmacro ^{:private true} pm [] 7) (pm))"] + ["multi-form body" "6" "(do (defmacro mb ([a b] (list (quote +) a b))) (mb 2 4))"]) + +# Multi-arity defmacro (dispatch on arg count) and the docstring + attr-map + +# params form — both needed to run real Clojure macros, e.g. +# clojure.tools.logging/log (4 arities) and its level macros (jolt-q8l, jolt-qnr). +(defspec "macros / defmacro multi-arity & attr-map" + ["multi-arity 1" "6" "(do (defmacro ma ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b))) (ma 5))"] + ["multi-arity 2" "5" "(do (defmacro ma ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b))) (ma 2 3))"] + ["arity delegates" "[:d nil 9]" + "(do (defmacro lg ([m] `(lg :d nil ~m)) ([l t m] (list (quote vector) l t m))) (lg 9))"] + ["doc + attr-map + params" "10" + "(do (defmacro am \"doc\" {:arglists (quote ([x]))} [x] (list (quote inc) x)) (am 9))"] + ["doc + attr-map + variadic" "6" + "(do (defmacro vg \"d\" {:arglists (quote ([& a]))} [& xs] `(+ ~@xs)) (vg 1 2 3))"]) diff --git a/test/spec/maps-spec.janet b/test/spec/maps-spec.janet index 5be1d87..14fc6cc 100644 --- a/test/spec/maps-spec.janet +++ b/test/spec/maps-spec.janet @@ -177,3 +177,13 @@ ["empty? lazy nil elem" "false" "(empty? (cons nil nil))"] ["empty? sorted" "[true false]" "[(empty? (sorted-map)) (empty? (sorted-set 1))]"] ["empty? number throws" :throws "(empty? 5)"]) + +# (assoc nil k v) yields a real immutable map, not a raw host table, so +# assoc-in into absent keys nests countable/seqable maps (jolt-w4s). +(defspec "map / assoc on nil" + ["assoc nil is a map" "{:a 1}" "(assoc nil :a 1)"] + ["count of assoc nil" "1" "(count (assoc nil :a 1))"] + ["assoc-in nested countable" "1" "(count (:a (assoc-in {} [:a :b] 1)))"] + ["assoc-in deep get" "9" "(get-in (assoc-in {} [:a :b :c] 9) [:a :b :c])"] + ["seq over assoc-nil map" ":a" "(ffirst (seq (assoc nil :a 1)))"] + ["keys of assoc-nil map" "[:a]" "(vec (keys (assoc nil :a 1)))"]) diff --git a/test/spec/multimethods-spec.janet b/test/spec/multimethods-spec.janet index 3da4f6a..1dd8acb 100644 --- a/test/spec/multimethods-spec.janet +++ b/test/spec/multimethods-spec.janet @@ -54,3 +54,17 @@ "(do (defmulti pm5 identity) (defmethod pm5 :a [x] 1) (defmethod pm5 :b [x] 2) (prefer-method pm5 :a :b) (contains? (get (prefers pm5) :a) :b))"] ["exact match needs no preference" ":exact" "(do (derive :t/sq :t/rect) (defmulti pm6 identity) (defmethod pm6 :t/sq [x] :exact) (defmethod pm6 :t/rect [x] :parent) (pm6 :t/sq))"]) + +# defmulti drops a leading docstring/attr-map (jolt-es4 — it used to be taken as +# the dispatch fn). methods/get-method take the multimethod VALUE and recover +# the table, so a bare multifn ref works even when defmethods live elsewhere +# (jolt-9pu). +(defspec "multimethods / docstring & value-based table ops" + ["defmulti docstring" "\"A\"" + "(do (defmulti gd \"the dispatcher\" identity) (defmethod gd :a [_] \"A\") (gd :a))"] + ["defmulti doc+default" "\"d\"" + "(do (defmulti gx \"doc\" identity) (defmethod gx :default [_] \"d\") (gx :anything))"] + ["methods on value" "2" + "(do (defmulti gm identity) (defmethod gm 1 [_] :one) (defmethod gm 2 [_] :two) (count (methods gm)))"] + ["get-method on value" "true" + "(do (defmulti gg identity) (defmethod gg :a [_] :x) (fn? (get-method gg :a)))"]) diff --git a/test/spec/regex-spec.janet b/test/spec/regex-spec.janet index e852dfd..264a2ef 100644 --- a/test/spec/regex-spec.janet +++ b/test/spec/regex-spec.janet @@ -47,3 +47,18 @@ ["p{Ps}/p{Pe}" "\"(x)\"" `(re-matches #"^\p{Ps}x\p{Pe}$" "(x)")`] ["(?u) accepted" "\"hi\"" `(re-matches #"(?u)^hi$" "hi")`] ["unknown class throws" :throws `(re-pattern "\p{Greek}")`]) + +# java.util.regex.Pattern statics (jolt-47b): compile returns jolt's native +# regex value (so .split / str-ops accept it), MULTILINE maps to (?m), quote +# escapes metachars. Plus the regex String methods migratus uses. +(defspec "regex / Pattern statics & String regex methods" + ["Pattern/compile is a regex" "true" "(regex? (Pattern/compile \"a.c\"))"] + ["compiled .split" "[\"a\" \"b\" \"c\"]" "(.split (Pattern/compile \",\") \"a,b,c\")"] + ["str/replace w/ Pattern" "\"ab\"" "(do (require '[clojure.string :as s]) (s/replace \"a1b2\" (Pattern/compile \"[0-9]\") \"\"))"] + ["Pattern/MULTILINE ^" "true" "(boolean (re-find (Pattern/compile \"^x\" Pattern/MULTILINE) \"y\\nx\"))"] + ["Pattern/quote literal" "true" "(boolean (re-find (re-pattern (Pattern/quote \"a.c\")) \"za.cy\"))"] + ["Pattern/quote not meta" "false" "(boolean (re-find (re-pattern (Pattern/quote \"a.c\")) \"zabcy\"))"] + [".matches whole string" "true" "(.matches \"abc\" \"a.c\")"] + [".matches partial -> false" "false" "(.matches \"abcd\" \"a.c\")"] + [".replaceAll regex" "\"a-b-c\"" "(.replaceAll \"a_b_c\" \"_\" \"-\")"] + [".replaceFirst regex" "\"a-b_c\"" "(.replaceFirst \"a_b_c\" \"_\" \"-\")"]) diff --git a/test/spec/state-spec.janet b/test/spec/state-spec.janet index b959eb2..b35944c 100644 --- a/test/spec/state-spec.janet +++ b/test/spec/state-spec.janet @@ -37,3 +37,12 @@ (defspec "state / promises" ["promise deliver" "5" "(let [p (promise)] (deliver p 5) @p)"] ["promise undelivered" "nil" "(let [p (promise)] @p)"]) + +# Minimal synchronous agent shim (jolt has no thread pool/STM) — enough for +# libraries that hold an agent without depending on async dispatch. +(defspec "state / agents (synchronous shim)" + ["agent deref" "0" "(deref (agent 0))"] + ["agent with opts" "0" "(deref (agent 0 :error-mode :continue))"] + ["send-off applies" "5" "(let [a (agent 0)] (send-off a + 5) (deref a))"] + ["send applies" "7" "(let [a (agent 1)] (send a + 6) (deref a))"] + ["agent-error nil" "nil" "(agent-error (agent 0))"]) diff --git a/test/spec/strings-spec.janet b/test/spec/strings-spec.janet index b0ae2ad..daeceeb 100644 --- a/test/spec/strings-spec.janet +++ b/test/spec/strings-spec.janet @@ -62,3 +62,11 @@ ["get out of range nil" "nil" "(get \"abc\" 9)"] ["get negative nil" "nil" "(get \"abc\" -1)"] ["get default honored" ":none" "(get \"abc\" 9 :none)"]) + +# clojure.string/trim-newline (ported from clojure.string): strips trailing \n/\r. +(defspec "clojure.string / trim-newline" + ["trailing newline" "\"x\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"x\\n\"))"] + ["trailing \\r\\n" "\"x\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"x\\r\\n\"))"] + ["no trailing" "\"ab\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"ab\"))"] + ["only newlines" "\"\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"\\n\\n\"))"] + ["interior kept" "\"a\\nb\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"a\\nb\\n\"))"])