Host hooks for library class shims: __register-class-methods! + __register-instance-check!
clj-http-lite drives java.net URL/HttpURLConnection and java.io byte streams through .method interop. The Chez host had __register-class-ctor!/-statics! (what router/reitit needs) but no way to register instance methods on a shim object or to extend instance?. Add both, plus jolt.host/table?: - tagged-table .method dispatch: an htable-arm on record-method-dispatch routes (.m obj a*) through a per-tag method registry keyed off the table's jolt/type; unregistered methods fall through (sorted colls are htables too). - __register-instance-check! installs (fn [class-name val] -> true|false|nil), nil = fall through; chained ahead of the base instance-check. Runtime .ss shims, no re-mint. Unit covers dispatch, args, instance? both ways.
This commit is contained in:
parent
21fbc50014
commit
8c6623503f
2 changed files with 60 additions and 1 deletions
|
|
@ -657,4 +657,57 @@
|
|||
(def-var! "clojure.core" "__register-class-ctor!"
|
||||
(lambda (name proc) (register-class-ctor! name proc) jolt-nil))
|
||||
(def-var! "clojure.core" "__register-class-statics!"
|
||||
(lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil))
|
||||
(lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil))
|
||||
|
||||
;; ---- tagged-table method dispatch + pluggable instance? --------------------
|
||||
;; A jolt library can build stateful host objects with (jolt.host/tagged-table
|
||||
;; tag) and dispatch (.method obj ...) to handlers registered here, keyed by the
|
||||
;; table's "jolt/type" tag — the htable analogue of the jhost method registry
|
||||
;; above. jolt-lang/http-client uses this to emulate java.net URL /
|
||||
;; HttpURLConnection / java.io byte streams so clj-http-lite runs unchanged.
|
||||
(define tagged-methods-tbl (make-hashtable string-hash string=?)) ; tag-key -> (method-ht)
|
||||
(define (tag->method-key tag)
|
||||
(if (keyword-t? tag)
|
||||
(let ((ns (keyword-t-ns tag)))
|
||||
(if (and ns (not (jolt-nil? ns))) (string-append ns "/" (keyword-t-name tag)) (keyword-t-name tag)))
|
||||
(jolt-str-render-one tag)))
|
||||
(define (register-tagged-methods! tag members)
|
||||
(let* ((key (tag->method-key tag))
|
||||
(h (or (hashtable-ref tagged-methods-tbl key #f)
|
||||
(let ((nh (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! tagged-methods-tbl key nh) nh))))
|
||||
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
|
||||
|
||||
;; htable arm: dispatch (.method obj a*) through the table's tag method registry;
|
||||
;; an unregistered method falls through (sorted colls are htables too).
|
||||
(define %hs-rmd-htable record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f))))
|
||||
(let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f)))
|
||||
(f (and mh (hashtable-ref mh method-name #f))))
|
||||
(if f
|
||||
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||
(%hs-rmd-htable obj method-name rest-args))))))
|
||||
|
||||
(def-var! "clojure.core" "__register-class-methods!"
|
||||
(lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil))
|
||||
|
||||
;; Pluggable instance? — a library registers (fn [class-name-string val] -> true
|
||||
;; | false | nil); nil means "not my class, fall through". First non-nil wins.
|
||||
(define user-instance-checks '())
|
||||
(define %hs-instance-check instance-check)
|
||||
(set! instance-check
|
||||
(lambda (type-sym val)
|
||||
(let ((tname (symbol-t-name type-sym)))
|
||||
(let loop ((fs user-instance-checks))
|
||||
(if (null? fs)
|
||||
(%hs-instance-check type-sym val)
|
||||
(let ((r ((car fs) tname val)))
|
||||
(if (jolt-nil? r) (loop (cdr fs)) (if (jolt-truthy? r) #t #f))))))))
|
||||
(def-var! "clojure.core" "instance-check" instance-check)
|
||||
(def-var! "clojure.core" "__register-instance-check!"
|
||||
(lambda (f) (set! user-instance-checks (append user-instance-checks (list f))) jolt-nil))
|
||||
|
||||
;; (jolt.host/table? x) — is x a host tagged-table (the Janet-table replacement)?
|
||||
(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue