Dmitri Sotnikov
GitHub
commit
52bea0b620
26 changed files with 1214 additions and 114 deletions
|
|
@ -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 "#".
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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).
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -177,3 +177,30 @@
|
|||
(defmethod print-method :jolt/chan [c w]
|
||||
(.write w "#<channel>")
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
28
src/jolt/clojure/pprint.clj
Normal file
28
src/jolt/clojure/pprint.clj
Normal 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))
|
||||
|
|
@ -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))))))
|
||||
|
|
|
|||
338
src/jolt/clojure/tools/logging.clj
Normal file
338
src/jolt/clojure/tools/logging.clj
Normal 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
50
src/jolt/clojure/tools/logging/impl.clj
Normal 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)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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/<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-io!)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))"])
|
||||
|
|
|
|||
|
|
@ -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))"])
|
||||
|
|
|
|||
|
|
@ -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))"])
|
||||
|
|
|
|||
|
|
@ -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)))"])
|
||||
|
|
|
|||
|
|
@ -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)))"])
|
||||
|
|
|
|||
|
|
@ -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\" \"_\" \"-\")"])
|
||||
|
|
|
|||
|
|
@ -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))"])
|
||||
|
|
|
|||
|
|
@ -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\"))"])
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue