feat: java.io.File model + multimethod/assoc/defmulti fixes for migratus (jolt-hjw)
File API (jolt-hjw): io/file and (File. …) build a tagged :jolt/file value (instance? File true) with a full method surface (isFile/isDirectory/exists/ getName/getPath/getAbsolutePath/listFiles/toPath/delete/createNewFile/…) backed by os/ and file/. file-seq is File-aware (leaves are File values). str/slurp/spit coerce :jolt/file to its path. ClassLoader/getSystemClassLoader + a classloader stub whose getResource returns nil degrade migratus's classpath lookup to the filesystem. java.nio.file Path/FileSystem/PathMatcher are shimmed just enough for script-excluded?'s glob (recursive * / ? matcher). Three bugs found getting migratus's migration discovery to work: - (assoc nil k v) returned a raw janet table, not a map, so assoc-in built tables that count/seq rejected. Now returns an immutable map. - methods/get-method resolved the multimethod symbol at runtime in the current ns, so a bare multifn ref in its defining ns saw an empty table once defmethods lived elsewhere. Now they take the multimethod VALUE and recover the var via a registry (Clojure semantics). - defmulti now drops a leading docstring/attr-map (migratus's multimethods carry docstrings) instead of treating the docstring as the dispatch fn. Conformance 335/335 x3, clojure-test-suite at baseline.
This commit is contained in:
Yogthos
parent
9813186ef9
commit
b304c43333
6 changed files with 164 additions and 19 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -1744,6 +1749,19 @@
|
|||
(defn core-jdbc-make-stmt [w]
|
||||
@{:jolt/type :jolt/jdbc-stmt :exec (get w :exec) :cmds @[]})
|
||||
|
||||
# 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
|
||||
|
|
@ -1787,6 +1805,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))
|
||||
|
|
@ -1799,7 +1818,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)
|
||||
|
|
@ -2731,6 +2750,8 @@
|
|||
"__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
|
||||
|
|
|
|||
|
|
@ -1197,6 +1197,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
|
||||
|
|
@ -1292,6 +1299,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
|
||||
|
|
@ -1301,9 +1309,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);
|
||||
|
|
@ -1470,8 +1480,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)]
|
||||
|
|
@ -1510,16 +1522,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)
|
||||
|
|
@ -1588,6 +1605,10 @@
|
|||
# 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)
|
||||
|
|
|
|||
|
|
@ -537,6 +537,15 @@
|
|||
# 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})}))
|
||||
(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.
|
||||
|
|
@ -563,7 +572,85 @@
|
|||
(def out @[])
|
||||
(each c (get self :cmds) (array/push out ((get self :exec) c)))
|
||||
out)
|
||||
"close" (fn [self] nil)}))
|
||||
"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!)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue