simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request #95 from jolt-lang/migratus-fixes

Browse source 
Migratus fixes
This commit is contained in:
Dmitri Sotnikov 2026-06-13 23:13:43 +00:00 • committed by GitHub
commit 52bea0b620
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
26 changed files with 1214 additions and 114 deletions
Download patch file Download diff file Expand all files Collapse all files

9
docs/grammar.ebnf
View file

@ -123,9 +123,12 @@ deref = "@" , form ; (* (deref form) *)
metadata = "^" , meta-form , ws , form ; (* attach metadata to form *) metadata = "^" , meta-form , ws , form ; (* attach metadata to form *)
meta-form = map | keyword | symbol | string ; meta-form = map | keyword | symbol | string ;
(* Normalized like Clojure: a symbol or string is a type hint -> {:tag ...}; (* 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 a keyword -> {keyword true}; a map is used as-is. A keyword/symbol/string
rides on the symbol (it stays a bare symbol, so a hint like ^String is meta-form on a symbol rides ON the symbol (it stays a bare symbol, so a hint
transparent in params/lets/bodies); other targets use a runtime with-meta. *) 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 "#". Dispatch forms — introduced by "#".

17
docs/libraries.md
View file

@ -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 (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 * [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) `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.

15
jolt-core/clojure/core/00-syntax.clj
View file

@ -110,7 +110,12 @@
;; then. Its body resolves fn/map/reduce/cond at EXPANSION time, by which point all ;; 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. ;; of 00-syntax has loaded, so using them here is fine.
(defmacro ns [nm & clauses] (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] (fn [acc clause]
(if (seq? clause) (if (seq? clause)
(let [head (first clause) args (rest clause)] (let [head (first clause) args (rest clause)]
@ -341,10 +346,14 @@
(defmacro defn [fn-name & body] (defmacro defn [fn-name & body]
(let [body (if (and (seq body) (string? (first body))) (rest body) 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)))) 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, ;; 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) ;; 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 ;; Jolt doesn't enforce privacy, so defn- is just defn (matching how Clojure's own
;; defn- delegates to defn with :private metadata). ;; defn- delegates to defn with :private metadata).

6
jolt-core/clojure/core/20-coll.clj
View file

@ -519,7 +519,11 @@
;; via the host dir primitives. Paths (strings), not File objects. (Lives below ;; via the host dir primitives. Paths (strings), not File objects. (Lives below
;; tree-seq: forward references are analysis errors now — jolt-2o7.3.) ;; tree-seq: forward references are analysis errors now — jolt-2o7.3.)
(defn file-seq [root] (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. ;; Canonical flatten via tree-seq: the leaves (non-sequential nodes) in order.
;; Flattens lists too (sequential?), matching Clojure/CLJS. ;; Flattens lists too (sequential?), matching Clojure/CLJS.

18
jolt-core/clojure/core/30-macros.clj
View file

@ -21,8 +21,15 @@
;; clojure.core fns) so they compile as plain invokes. name/mm are passed quoted; ;; 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 ;; the dispatch fn, options, and dispatch value evaluate normally, and the method
;; body becomes a compiled (fn …). ;; body becomes a compiled (fn …).
(defmacro defmulti [name dispatch & opts] ;; Clojure allows (defmulti name docstring? attr-map? dispatch-fn & options);
`(defmulti-setup (quote ~name) ~dispatch ~@opts)) ;; 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] (defmacro defmethod [mm dispatch-val & fn-tail]
`(defmethod-setup (quote ~mm) ~dispatch-val (fn ~@fn-tail))) `(defmethod-setup (quote ~mm) ~dispatch-val (fn ~@fn-tail)))
@ -39,11 +46,14 @@
(defmacro remove-all-methods [mm] (defmacro remove-all-methods [mm]
`(remove-all-methods-setup (quote ~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] (defmacro get-method [mm dval]
`(get-method-setup (quote ~mm) ~dval)) `(get-method-setup ~mm ~dval))
(defmacro methods [mm] (defmacro methods [mm]
`(methods-setup (quote ~mm))) `(methods-setup ~mm))
;; prefers reads the store off the VAR (the multifn value can't carry it) — ;; prefers reads the store off the VAR (the multifn value can't carry it) —
;; same symbol-passing shape as the other multimethod table ops. ;; same symbol-passing shape as the other multimethod table ops.

27
jolt-core/clojure/core/50-io.clj
View file

@ -177,3 +177,30 @@
(defmethod print-method :jolt/chan [c w] (defmethod print-method :jolt/chan [c w]
(.write w "#<channel>") (.write w "#<channel>")
nil) 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)

11
jolt-core/jolt/analyzer.clj
View file

@ -182,9 +182,16 @@
(when (< (count items) 3) (when (< (count items) 3)
(uncompilable "def with no init")) (uncompilable "def with no init"))
(let [nm (form-sym-name name-sym) (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) (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))) "let*" (let [bvec (vec (form-vec-items (nth items 1)))
r (analyze-bindings ctx bvec env)] r (analyze-bindings ctx bvec env)]
(let-node (first r) (analyze-seq ctx (drop 2 items) (second r)))) (let-node (first r) (analyze-seq ctx (drop 2 items) (second r))))

18
src/jolt/backend.janet
View file

@ -191,11 +191,25 @@
(tuple/slice (array/concat @[(symbol (node :recur-name))] (tuple/slice (array/concat @[(symbol (node :recur-name))]
(map |(emit ctx $) (vview (node :args)))))) (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] (defn- emit-try [ctx node]
(def core (def core
(if (node :catch-sym) (if (node :catch-sym)
['try (emit ctx (node :body)) # Restore current-ns in the catch: a caught throw from an INTERPRETED fn
[[(symbol (node :catch-sym))] (emit ctx (node :catch-body))]] # 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)))) (emit ctx (node :body))))
(if (node :finally) (if (node :finally)
['defer (emit ctx (node :finally)) core] ['defer (emit ctx (node :finally)) core]

10
src/jolt/clojure/java/io.clj
View file

@ -6,11 +6,13 @@
; …) won't work, but file/reader/writer/resource/copy/slurp do. ; …) won't work, but file/reader/writer/resource/copy/slurp do.
(defn file (defn file
"A file path. With a parent and child, joins them with '/'." "A java.io.File. With a parent and child, joins them with '/'. Returns a
([path] (str path)) :jolt/file value (instance? File true) with the File method surface; str/slurp
([parent child] (str parent "/" child))) 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] (defn reader [x]
(cond (cond

28
src/jolt/clojure/pprint.clj Normal file
View file

@ -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))

14
src/jolt/clojure/string.clj
View file

@ -135,3 +135,17 @@
(let [c (str ch)] (let [c (str ch)]
(if (or (= c "\\") (= c "$")) (str "\\" c) c))) (if (or (= c "\\") (= c "$")) (str "\\" c) c)))
(seq replacement)))) (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))))))

338
src/jolt/clojure/tools/logging.clj Normal file
View file

@ -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))

50
src/jolt/clojure/tools/logging/impl.clj Normal file
View file

@ -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)

52
src/jolt/core.janet
View file

@ -541,7 +541,10 @@
result) result)
(do (var result @{}) (when m (each k (keys m) (put result k (get m k)))) (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))) (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] (defn core-dissoc [m & ks]
(cond (cond
@ -1656,6 +1659,8 @@
(if (v :ns) (string (v :ns) "/" (v :name)) (v :name)) (if (v :ns) (string (v :ns) "/" (v :name)) (v :name))
(and (struct? v) (= :jolt/uuid (v :jolt/type))) (v :str) (and (struct? v) (= :jolt/uuid (v :jolt/type))) (v :str)
(and (struct? v) (= :jolt/inst (v :jolt/type))) (inst->rfc3339 v) (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) (= :jolt/namespace (get v :jolt/type)) (ns-display-name v)
(and (table? v) (= :jolt/var (get v :jolt/type))) (var-display v) (and (table? v) (= :jolt/var (get v :jolt/type))) (var-display v)
(number? v) (fmt-number v) (number? v) (fmt-number v)
@ -1724,6 +1729,41 @@
# the __write / __pr-str1 host seams; str-render-one stays for core-str. # the __write / __pr-str1 host seams; str-render-one stays for core-str.
(defn core-write [s] (prin s) nil) (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). # newline lives in the Clojure collection tier (core/20-coll.clj).
# Clojure 1.11 string->scalar parsers: nil on malformed input, throw on a # 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. # bodies, and the jolt Ring adapter hands those over as StringReaders.
(defn core-slurp [src & opts] (defn core-slurp [src & opts]
(cond (cond
(core-file? src) (string (slurp (core-file-path src)))
(and (table? src) (string? (get src :s)) (number? (get src :pos))) (and (table? src) (string? (get src :s)) (number? (get src :pos)))
(let [s (src :s) p (src :pos)] (let [s (src :s) p (src :pos)]
(put src :pos (length s)) (put src :pos (length s))
@ -1779,7 +1820,7 @@
(when (and (= :append (in opts i)) (in opts (+ i 1))) (set a true)) (when (and (= :append (in opts i)) (in opts (+ i 1))) (set a true))
(+= i 2)) (+= i 2))
a)) 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/write f (str-render-one content))
(file/close f) (file/close f)
nil) nil)
@ -2706,6 +2747,13 @@
"hash-unordered-coll" core-hash-unordered-coll "hash-unordered-coll" core-hash-unordered-coll
"gensym" gensym "gensym" gensym
"__write" core-write "__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 "__pr-str1" core-pr-str1
"__make-uuid" make-uuid "__make-uuid" make-uuid
"compare" core-compare "compare" core-compare

269
src/jolt/evaluator.janet
View file

@ -198,7 +198,16 @@
{:jolt/type :symbol {:jolt/type :symbol
:ns (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx)) :ns (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx))
:name nm})) :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 (defn- d-realize
"Realize a lazy-seq to an array for positional destructuring / splicing; pass "Realize a lazy-seq to an array for positional destructuring / splicing; pass
@ -526,7 +535,9 @@
# future doesn't block the parent. # future doesn't block the parent.
(def- thread-statics (def- thread-statics
{"sleep" (fn [ms] (ev/sleep (/ ms 1000)) nil) {"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). # System statics (wall/monotonic clocks — what portable timing code uses).
(def- system-statics (def- system-statics
@ -583,7 +594,12 @@
(def n (scan-number (string/trim (string s)) (or radix 10))) (def n (scan-number (string/trim (string s)) (or radix 10)))
(if (and n (= n (math/floor n))) (if (and n (= n (math/floor n)))
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): # Pluggable host-class shims (java.time etc. register here at module load):
# class-statics: "ClassName" -> {"member" value-or-fn} (Foo/bar resolution) # class-statics: "ClassName" -> {"member" value-or-fn} (Foo/bar resolution)
@ -611,7 +627,11 @@
"StringReader" "java.io.StringReader" "StringWriter" "java.io.StringWriter" "StringReader" "java.io.StringReader" "StringWriter" "java.io.StringWriter"
"StringBuilder" "java.lang.StringBuilder" "StringBuilder" "java.lang.StringBuilder"
"StringTokenizer" "java.util.StringTokenizer" "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 (defn- class-value-for
"The value a class-name symbol evaluates to: its canonical name string." "The value a class-name symbol evaluates to: its canonical name string."
[nm] [nm]
@ -698,7 +718,10 @@
"endsWith" (fn [s p] (string/has-suffix? p s)) "endsWith" (fn [s p] (string/has-suffix? p s))
"contains" (fn [s sub] (not (nil? (string/find (str-needle sub) s)))) "contains" (fn [s sub] (not (nil? (string/find (str-needle sub) s))))
"concat" (fn [s o] (string s o)) "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)) "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))))}) "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 # No implicit Janet fallback (Stage 3): an unresolved
# Clojure symbol is an error. Host access is the explicit # Clojure symbol is an error. Host access is the explicit
# janet/ prefix above. # 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 (defn- parse-arg-names
"Parse a parameter vector, handling & rest args. "Parse a parameter vector, handling & rest args.
Returns {:fixed [names...] :rest name-or-nil :all [names...]}" 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)))))) (ns-unmap ns (if (and (struct? sym) (= :symbol (sym :jolt/type))) (sym :name) (string sym))))))
nil) 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 (defn defmulti-setup
"(defmulti name dispatch & opts) — intern a multimethod var. A fn; name arrives "(defmulti name dispatch & opts) — intern a multimethod var. A fn; name arrives
quoted, dispatch + opts (:default key, :hierarchy h) arrive evaluated. The quoted, dispatch + opts (:default key, :hierarchy h) arrive evaluated. The
@ -1296,6 +1328,7 @@
(put v :jolt/dispatch-cache dispatch-cache) (put v :jolt/dispatch-cache dispatch-cache)
(put v :jolt/default default-key) (put v :jolt/default default-key)
(when hierarchy (put v :jolt/hierarchy hierarchy)) (when hierarchy (put v :jolt/hierarchy hierarchy))
(put multi-registry mm-fn v)
(var-get v)) (var-get v))
(defn defmethod-setup (defn defmethod-setup
@ -1305,9 +1338,11 @@
[ctx mm-sym dispatch-val impl] [ctx mm-sym dispatch-val impl]
(def mm-var (def mm-var
(or (resolve-var ctx @{} mm-sym) (or (resolve-var ctx @{} mm-sym)
(let [ns (ctx-find-ns ctx (ctx-current-ns ctx))] (let [ns (ctx-find-ns ctx (ctx-current-ns ctx))
(def v (ns-intern ns (mm-sym :name) (fn [& args] nil))) stub (fn [& args] nil)]
(def v (ns-intern ns (mm-sym :name) stub))
(put v :jolt/methods @{}) (put v :jolt/methods @{})
(put multi-registry stub v)
v))) v)))
(def methods (or (get mm-var :jolt/methods) (let [m @{}] (put mm-var :jolt/methods m) m))) (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); # nil is a legal dispatch value (ring's body-string keys a method on it);
@ -1339,6 +1374,12 @@
expand to calls of these)." expand to calls of these)."
[ctx] [ctx]
(def core (ctx-find-ns ctx "clojure.core")) (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" (ns-intern core "protocol-dispatch"
(fn [proto-name method-name obj rest-args] (fn [proto-name method-name obj rest-args]
(protocol-dispatch-impl ctx proto-name method-name obj rest-args))) (protocol-dispatch-impl ctx proto-name method-name obj rest-args)))
@ -1474,8 +1515,10 @@
found found
(when auto-create? (when auto-create?
(def ns (ctx-find-ns ctx (ctx-current-ns ctx))) (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 nv :jolt/methods @{})
(put multi-registry stub nv)
nv)))) nv))))
(def clear-dispatch-cache! (fn [mm-var] (def clear-dispatch-cache! (fn [mm-var]
(let [dc (get mm-var :jolt/dispatch-cache)] (let [dc (get mm-var :jolt/dispatch-cache)]
@ -1514,16 +1557,21 @@
(fn [mm-sym] (fn [mm-sym]
(def mm-var (mm-var-of mm-sym false)) (def mm-var (mm-var-of mm-sym false))
(or (and mm-var (get mm-var :jolt/prefers)) {}))) (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" (ns-intern core "get-method-setup"
(fn [mm-sym dval] (fn [mm dval]
(def dval (if (nil? dval) :jolt/nil-sentinel 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 (when mm-var
(let [methods (get mm-var :jolt/methods)] (let [methods (get mm-var :jolt/methods)]
(or (get methods dval) (get methods :default)))))) (or (get methods dval) (get methods :default))))))
(ns-intern core "methods-setup" (ns-intern core "methods-setup"
(fn [mm-sym] (fn [mm]
(def mm-var (mm-var-of mm-sym false)) (def mm-var (mm-var-of-val mm))
(when mm-var (when mm-var
# a jolt map, not the live host table (and phm so vector dispatch # a jolt map, not the live host table (and phm so vector dispatch
# values look up by value, same reason build-eval-map promotes) # 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))) "DateTimeFormatter" (and (table? val) (= :jolt/dt-formatter (get val :jolt/type)))
"URL" (and (table? val) (= :jolt/url (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))) "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 # JVM char[] class — (Class/forName "[C"); jolt char arrays are Janet
# arrays of char structs # arrays of char structs
"[C" (and (array? val) "[C" (and (array? val)
@ -1797,28 +1854,59 @@
(put v :dynamic true)) (put v :dynamic true))
# def returns the var (Clojure semantics); REPL prints #'ns/name # def returns the var (Clojure semantics); REPL prints #'ns/name
v))) v)))
"defmacro" (let [name-sym (in form 1) "defmacro" (let [# ^{:map} metadata on the name reads as a (with-meta sym …)
rest-form (tuple/slice form 2) # form (jolt-8w2); unwrap to the bare symbol like def does.
# optional docstring name-sym (unwrap-meta-name (in form 1))
has-doc? (and (> (length rest-form) 0) (string? (first rest-form))) after-name (tuple/slice form 2)
args-form (if has-doc? (in rest-form 1) (first rest-form)) # Skip an optional leading docstring (string) then an optional
body (tuple/slice rest-form (if has-doc? 2 1)) # attr-map (a struct that is not a symbol — a map literal reads
param-info (parse-params args-form) # as a struct), matching defn. Real macros use both, e.g.
fixed-pats (param-info :fixed) # (defmacro info "doc" {:arglists '(...)} [& args] …).
rest-pat (param-info :rest) 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)] defining-ns (ctx-current-ns ctx)]
(def interp-fn (fn [& macro-args] (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 @{}) (var new-bindings @{})
(table/setproto new-bindings bindings) (table/setproto new-bindings bindings)
(put new-bindings "&env" @{}) # implicit &env for macro bodies (table — nil-safe) (put new-bindings "&env" @{}) # implicit &env for macro bodies (table — nil-safe)
(var i 0) (var i 0)
# Destructure macro params (like fn), so [& [a & more :as all]] # Destructure macro params (like fn), so [& [a & more :as all]]
# and {:keys …} rest forms work in macro arglists. # 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)) (destructure-bind ctx new-bindings pat (macro-args i))
(++ i)) (++ i))
(when rest-pat (when (pi :rest)
(destructure-bind ctx new-bindings rest-pat (rest-args-val macro-args i))) (destructure-bind ctx new-bindings (pi :rest) (rest-args-val macro-args i)))
# Use defining namespace for symbol resolution # Use defining namespace for symbol resolution
(def saved-ns (ctx-current-ns ctx)) (def saved-ns (ctx-current-ns ctx))
(ctx-set-current-ns ctx defining-ns) (ctx-set-current-ns ctx defining-ns)
@ -1831,12 +1919,20 @@
(set result (eval-form ctx new-bindings bf))) (set result (eval-form ctx new-bindings bf)))
(ctx-set-current-ns ctx saved-ns) (ctx-set-current-ns ctx saved-ns)
result)) result))
# Prefer a COMPILED expander (native-speed expansion, zero runtime # A COMPILED expander (native-speed) is only built for the
# cost). Skip when the body uses &env/&form (the compiled fn has no # single-arity case (the compile hook + recompile path take one
# such params) — those fall back to the interpreted closure. # [args body]); multi-arity macros use the interpreted expander.
(def uses-env (or (form-uses-sym? body "&env") (form-uses-sym? body "&form"))) (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 (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))) (macro-compile-hook ctx args-form body)))
(def macro-fn (or compiled-fn interp-fn)) (def macro-fn (or compiled-fn interp-fn))
(let [ns-name (ctx-current-ns ctx) (let [ns-name (ctx-current-ns ctx)
@ -1847,8 +1943,10 @@
# compile it once the analyzer is alive (staged bootstrap): a # compile it once the analyzer is alive (staged bootstrap): a
# macro defined WHILE the analyzer is still being built gets an # macro defined WHILE the analyzer is still being built gets an
# interpreted closure now, a compiled expander later. uses-env # interpreted closure now, a compiled expander later. uses-env
# macros stay interpreted (the compiled fn* has no &env/&form). # macros stay interpreted (the compiled fn* has no &env/&form);
(put v :macro-src @[args-form body]) # 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) (put v :macro-uses-env uses-env)
(when compiled-fn (put v :macro-compiled true)) (when compiled-fn (put v :macro-compiled true))
# A (re)defined macro invalidates any cached expansions. # A (re)defined macro invalidates any cached expansions.
@ -2065,9 +2163,20 @@
(apply loop-fn args)))) (apply loop-fn args))))
"throw" (let [val (eval-form ctx bindings (in form 1))] "throw" (let [val (eval-form ctx bindings (in form 1))]
(error {:jolt/type :jolt/exception :value val})) (error {:jolt/type :jolt/exception :value val}))
"try" (let [body-form (in form 1) "try" (let [# The body is EVERY form between `try` and the first catch/finally
clauses (tuple/slice form 2) # clause (not just form 1 — a multi-form body before the clauses,
n (length 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 # current-ns is dynamic state. The interpreter rebinds it to a
# fn's defining ns while that fn runs and restores it on normal # 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 # return, but a fn that THROWS unwinds past its own restore — so
@ -2078,52 +2187,49 @@
(var catch-sym nil) (var catch-sym nil)
(var catch-body nil) (var catch-body nil)
(var finally-body nil) (var finally-body nil)
(var i 0) (each clause clauses
(while (< i n) (when (and (array? clause) (> (length clause) 0))
(let [clause (in clauses i)] (let [head (first clause)]
(if (and (array? clause) (> (length clause) 0)) (when (and (struct? head) (= :symbol (head :jolt/type)))
(let [head (first clause)] (match (head :name)
(if (and (struct? head) (= :symbol (head :jolt/type))) "catch" (do
(match (head :name) (set catch-sym (in clause 2))
"catch" (do (set catch-body (tuple/slice clause 3)))
(set catch-sym (in clause 2)) "finally" (set finally-body (tuple/slice clause 1)))))))
(set catch-body (tuple/slice clause 3))) (defn eval-body []
"finally" (set finally-body (tuple/slice clause 1))))))) (var result nil)
(++ i)) (each bf body-forms (set result (eval-form ctx bindings bf)))
(defn run-finally [f] result)
(when f (defn run-finally []
(each fb f (eval-form ctx bindings fb)))) (when finally-body
(if catch-sym (each fb finally-body (eval-form ctx bindings fb))))
(try (defn run-protected []
(eval-form ctx bindings body-form) (if catch-sym
([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
(try (try
(do (eval-body)
(def result (eval-form ctx bindings body-form))
(run-finally finally-body)
result)
([err] ([err]
(ctx-set-current-ns ctx try-ns) (ctx-set-current-ns ctx try-ns)
(run-finally finally-body) (var new-bindings @{})
(error err))) (table/setproto new-bindings bindings)
(eval-form ctx bindings body-form)))) # 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) "set!" (let [target (in form 1)
val (eval-form ctx bindings (in form 2))] val (eval-form ctx bindings (in form 2))]
# Handle (set! (.-field obj) val) — .-field shorthand as a list # Handle (set! (.-field obj) val) — .-field shorthand as a list
@ -2365,8 +2471,11 @@
(if (= :jolt/char (form :jolt/type)) (if (= :jolt/char (form :jolt/type))
form form
# a UUID/inst value flowing back through eval (macro expansion, eval of a # a UUID/inst value flowing back through eval (macro expansion, eval of a
# read form) is a self-evaluating literal, like chars. # read form) is a self-evaluating literal, like chars. A namespace object
(if (or (= :jolt/uuid (form :jolt/type)) (= :jolt/inst (form :jolt/type))) # 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 form
(if (= :jolt/set (form :jolt/type)) (if (= :jolt/set (form :jolt/type))
# evaluate each element (set literals like #{(inc 1)} must compute) # evaluate each element (set literals like #{(inc 1)} must compute)

213
src/jolt/javatime.janet
View file

@ -6,6 +6,7 @@
# install call — adding another java.* shim follows the same shape. # install call — adding another java.* shim follows the same shape.
(use ./evaluator) (use ./evaluator)
(use ./regex)
(import ./phm) (import ./phm)
(defn- chr [s] (get s 0)) (defn- chr [s] (get s 0))
@ -442,7 +443,217 @@
(or (scan-number (string/trim (string v))) (or (scan-number (string/trim (string v)))
(error (string "NumberFormatException: For input string: \"" v "\"")))))) (error (string "NumberFormatException: For input string: \"" v "\""))))))
(each nm ["Locale" "java.util.Locale"] (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/<dir>). 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!)
(install-io!) (install-io!)

32
src/jolt/regex.janet
View file

@ -144,23 +144,29 @@
(let [inner (parse-alt st)] (+= (st :pos) 1) {:op :look :neg false :item inner})) (let [inner (parse-alt st)] (+= (st :pos) 1) {:op :look :neg false :item inner}))
(= k (chr "!")) (do (+= (st :pos) 3) (= k (chr "!")) (do (+= (st :pos) 3)
(let [inner (parse-alt st)] (+= (st :pos) 1) {:op :look :neg true :item inner})) (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 (do
(var j (+ (st :pos) 2)) (var j (+ (st :pos) 2))
(var seti false) (var seti false)
(var setm false)
(while (and (< j (length s)) (not= (s j) (chr ")")) (not= (s j) (chr ":"))) (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 "i")) (set seti true))
(when (= (s j) (chr "m")) (set setm true))
(++ j)) (++ j))
(if (= (s j) (chr ":")) (if (= (s j) (chr ":"))
(do (set (st :pos) (+ j 1)) (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 seti (set (st :ci) true))
(when setm (set (st :ml) true))
(def inner (parse-alt st)) (def inner (parse-alt st))
(set (st :ci) saved) (set (st :ci) savedci)
(set (st :ml) savedml)
(+= (st :pos) 1) (+= (st :pos) 1)
{:op :ncgroup :item inner}) {: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 seti (set (st :ci) true))
(when setm (set (st :ml) true))
{:op :seq :items @[]}))))) {:op :seq :items @[]})))))
# capturing group # capturing group
(let [n (++ (st :ngroup))] (let [n (++ (st :ngroup))]
@ -235,9 +241,9 @@
(if (= 1 (length branches)) (branches 0) {:op :alt :items branches}))) (if (= 1 (length branches)) (branches 0) {:op :alt :items branches})))
(defn- parse [source] (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)) (def ast (parse-alt st))
[ast (st :ngroup)]) [ast (st :ngroup) (st :ml)])
# ============================================================ # ============================================================
# Emit: AST -> PEG grammar (continuation passing) # Emit: AST -> PEG grammar (continuation passing)
@ -250,7 +256,7 @@
~(set ,(string/from-bytes (lower-b b) (upper-b b))) ~(set ,(string/from-bytes (lower-b b) (upper-b b)))
~(set ,(string/from-bytes b)))) ~(set ,(string/from-bytes b))))
(defn- make-emitter [grammar] (defn- make-emitter [grammar ml]
(var ctr 0) (var ctr 0)
(defn fresh [] (++ ctr) (keyword (string "r" ctr))) (defn fresh [] (++ ctr) (keyword (string "r" ctr)))
(var emit nil) (var emit nil)
@ -304,8 +310,12 @@
~(sequence (not ,(emit (ast :item) 0)) ,k) ~(sequence (not ,(emit (ast :item) 0)) ,k)
~(sequence (not (not ,(emit (ast :item) 0))) ,k)) ~(sequence (not (not ,(emit (ast :item) 0))) ,k))
:anchor (case (ast :kind) :anchor (case (ast :kind)
:start ~(sequence (not (look -1 1)) ,k) :start (if ml
:end ~(sequence (not 1) ,k) ~(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)) :wordb ~(sequence (choice (sequence (look -1 ,word-frag) (not ,word-frag))
(sequence (not (look -1 ,word-frag)) (not (not ,word-frag)))) (sequence (not (look -1 ,word-frag)) (not (not ,word-frag))))
,k) ,k)
@ -317,9 +327,9 @@
emit) emit)
(defn compile-regex [source] (defn compile-regex [source]
(def [ast ngroups] (parse source)) (def [ast ngroups ml] (parse source))
(def grammar @{}) (def grammar @{})
(def emit (make-emitter grammar)) (def emit (make-emitter grammar ml))
# group 0 = whole match: mark start, body, mark end # group 0 = whole match: mark start, body, mark end
(def body (emit ast ~(sequence (/ (position) ,(fn [p] [0 :e p])) 0))) (def body (emit ast ~(sequence (/ (position) ,(fn [p] [0 :e p])) 0)))
(put grammar :main ~(sequence (/ (position) ,(fn [p] [0 :s p])) ,body)) (put grammar :main ~(sequence (/ (position) ,(fn [p] [0 :s p])) ,body))

52
test/integration/conformance-test.janet
View file

@ -462,6 +462,58 @@
["not-any?" "true" "(not-any? even? [1 3 5])"] ["not-any?" "true" "(not-any? even? [1 3 5])"]
["take-last" "[3 4]" "(take-last 2 [1 2 3 4])"] ["take-last" "[3 4]" "(take-last 2 [1 2 3 4])"]
["replace nil val" "[1 nil 3]" "(replace {2 nil} [1 2 3])"] ["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 # Run every case under a given context factory and return the failures. The same

5
test/integration/fallback-zero-test.janet
View file

@ -67,7 +67,10 @@
"(refer (quote clojure.string))" "(refer (quote clojure.string))"
# Stage 2 tier 6c: dispatch-table ops + misc compile as macros/plain invokes # 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)" "(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)" "(satisfies? P 5)" "(instance? String \"x\")" "(locking :x 1)"
"(defonce fz-once 1)" "(read-string \"[1 2]\")" "(defonce fz-once 1)" "(read-string \"[1 2]\")"
"(macroexpand-1 (quote (when true 1)))"]) "(macroexpand-1 (quote (when true 1)))"])

67
test/spec/host-interop-spec.janet
View file

@ -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)"] "(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" ["restore returns to default" "false"
"(do (def prev (__reader-features)) (__reader-features-set! [\"clj\"]) (__reader-features-set! prev) (contains? (set (__reader-features)) \"clj\"))"]) "(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))"])

21
test/spec/macros-spec.janet
View file

@ -85,3 +85,24 @@
["with-redefs-fn" "42" "(do (defn wr-i [] 1) (with-redefs-fn {(var wr-i) (fn [] 42)} (fn [] (wr-i))))"] ["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 full" "true" "(let [e (macroexpand (quote (when-not false 1)))] (= (quote if) (first e)))"]
["macroexpand non-macro" "[1 2]" "(macroexpand (quote [1 2]))"]) ["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))"])

10
test/spec/maps-spec.janet
View file

@ -177,3 +177,13 @@
["empty? lazy nil elem" "false" "(empty? (cons nil nil))"] ["empty? lazy nil elem" "false" "(empty? (cons nil nil))"]
["empty? sorted" "[true false]" "[(empty? (sorted-map)) (empty? (sorted-set 1))]"] ["empty? sorted" "[true false]" "[(empty? (sorted-map)) (empty? (sorted-set 1))]"]
["empty? number throws" :throws "(empty? 5)"]) ["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)))"])

14
test/spec/multimethods-spec.janet
View file

@ -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))"] "(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" ["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))"]) "(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)))"])

15
test/spec/regex-spec.janet
View file

@ -47,3 +47,18 @@
["p{Ps}/p{Pe}" "\"(x)\"" `(re-matches #"^\p{Ps}x\p{Pe}$" "(x)")`] ["p{Ps}/p{Pe}" "\"(x)\"" `(re-matches #"^\p{Ps}x\p{Pe}$" "(x)")`]
["(?u) accepted" "\"hi\"" `(re-matches #"(?u)^hi$" "hi")`] ["(?u) accepted" "\"hi\"" `(re-matches #"(?u)^hi$" "hi")`]
["unknown class throws" :throws `(re-pattern "\p{Greek}")`]) ["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\" \"_\" \"-\")"])

9
test/spec/state-spec.janet
View file

@ -37,3 +37,12 @@
(defspec "state / promises" (defspec "state / promises"
["promise deliver" "5" "(let [p (promise)] (deliver p 5) @p)"] ["promise deliver" "5" "(let [p (promise)] (deliver p 5) @p)"]
["promise undelivered" "nil" "(let [p (promise)] @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))"])

8
test/spec/strings-spec.janet
View file

@ -62,3 +62,11 @@
["get out of range nil" "nil" "(get \"abc\" 9)"] ["get out of range nil" "nil" "(get \"abc\" 9)"]
["get negative nil" "nil" "(get \"abc\" -1)"] ["get negative nil" "nil" "(get \"abc\" -1)"]
["get default honored" ":none" "(get \"abc\" 9 :none)"]) ["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\"))"])