Merge pull request #99 from jolt-lang/field-types
Records across namespaces: field type hints, cross-ns hints, whole-program var const-linking
This commit is contained in:
commit
230a0c2160
9 changed files with 277 additions and 38 deletions
|
|
@ -286,6 +286,15 @@
|
|||
;; a seq of field keywords; spliced into a vector LITERAL below ([~@…]) so
|
||||
;; the analyzer sees a vector form, not a runtime pvec value.
|
||||
field-kws (map (fn [f] (keyword (name f))) fields)
|
||||
;; per-field TYPE HINT (jolt-3ko): ^Vec3 origin -> "Vec3" (a record type
|
||||
;; name), ^:num x -> "num", else nil. Lets the inference know a field's
|
||||
;; exact type up front, so reading it back carries that type (not :any) —
|
||||
;; the key to fast nested-record code. Spliced as a vector literal too.
|
||||
field-tags (map (fn [f] (let [mt (meta f)]
|
||||
(cond (and mt (:tag mt)) (:tag mt)
|
||||
(and mt (:num mt)) "num"
|
||||
:else nil)))
|
||||
fields)
|
||||
impl (fn [proto specs]
|
||||
`(extend-type ~tname ~proto
|
||||
~@(map (fn [spec]
|
||||
|
|
@ -295,7 +304,7 @@
|
|||
`(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec)))))
|
||||
specs)))]
|
||||
`(do
|
||||
(def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws]))
|
||||
(def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws] [~@field-tags]))
|
||||
(def ~arrow ~tname)
|
||||
~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body))
|
||||
~tname)))
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@
|
|||
form-map-pairs form-set-items form-special? compile-ns
|
||||
form-macro? form-expand-1 resolve-global
|
||||
form-sym-meta host-intern! form-syntax-quote-lower
|
||||
record-type? form-position]]))
|
||||
record-type? record-ctor-key form-position]]))
|
||||
|
||||
(declare analyze)
|
||||
|
||||
|
|
@ -61,6 +61,16 @@
|
|||
(defn- add-hint [env nm h]
|
||||
(if h (assoc env :hints (assoc (:hints env) nm h)) env))
|
||||
|
||||
;; The resolved record ctor-key ("ns/->Name") for a ^Type param hint, or nil.
|
||||
;; Unlike hint-of (which collapses any record hint to the coarse :struct guard-
|
||||
;; skip marker), this carries the SPECIFIC record type — cross-namespace aware —
|
||||
;; so the inference can seed the param's type and read its fields shaped/typed,
|
||||
;; not just :any (the lever for a typed multi-namespace program without whole-
|
||||
;; program inference).
|
||||
(defn- phint-of [ctx sym]
|
||||
(let [m (form-sym-meta sym)]
|
||||
(when m (let [t (get m :tag)] (when t (record-ctor-key ctx t))))))
|
||||
|
||||
(defn- analyze-seq [ctx forms env]
|
||||
(let [v (mapv #(analyze ctx % env) forms)
|
||||
n (count v)]
|
||||
|
|
@ -83,18 +93,21 @@
|
|||
(defn- parse-params [ctx pvec]
|
||||
;; :hints is a vector of [name hint] pairs (vector, not a map, so the caller
|
||||
;; folds it with a plain reduce — no reduce-over-map in the kernel subset).
|
||||
(loop [i 0 fixed [] rest-name nil hints []]
|
||||
;; :phints is the parallel vector of [name ctor-key] for record param hints,
|
||||
;; carrying the specific type for the inference to seed.
|
||||
(loop [i 0 fixed [] rest-name nil hints [] phints []]
|
||||
(if (< i (count pvec))
|
||||
(let [p (nth pvec i)]
|
||||
(when-not (form-sym? p) (uncompilable "destructuring fn param"))
|
||||
(if (= "&" (form-sym-name p))
|
||||
(let [r (nth pvec (inc i))]
|
||||
(when-not (form-sym? r) (uncompilable "destructuring fn rest"))
|
||||
(recur (+ i 2) fixed (form-sym-name r) hints))
|
||||
(let [nm (form-sym-name p) h (hint-of ctx p)]
|
||||
(recur (+ i 2) fixed (form-sym-name r) hints phints))
|
||||
(let [nm (form-sym-name p) h (hint-of ctx p) ph (phint-of ctx p)]
|
||||
(recur (inc i) (conj fixed nm) rest-name
|
||||
(if h (conj hints [nm h]) hints)))))
|
||||
{:fixed fixed :rest rest-name :hints hints})))
|
||||
(if h (conj hints [nm h]) hints)
|
||||
(if ph (conj phints [nm ph]) phints)))))
|
||||
{:fixed fixed :rest rest-name :hints hints :phints phints})))
|
||||
|
||||
(defn- analyze-arity [ctx pvec body env fn-name]
|
||||
(let [pp (parse-params ctx (vec (form-vec-items pvec)))
|
||||
|
|
@ -113,7 +126,10 @@
|
|||
env0 (-> (add-locals env names) (with-recur rname))
|
||||
env* (reduce (fn [e pr] (add-hint e (nth pr 0) (nth pr 1))) env0 (:hints pp))
|
||||
arity {:params fixed :recur-name rname
|
||||
:body (analyze-seq ctx body env*)}]
|
||||
:body (analyze-seq ctx body env*)}
|
||||
;; carry record param hints (name -> ctor-key) for the inference to seed
|
||||
;; the param type; only when present so a hintless arity stays a struct.
|
||||
arity (if (seq (:phints pp)) (assoc arity :phints (:phints pp)) arity)]
|
||||
;; :rest only when variadic — an absent :rest reads back nil, same as before,
|
||||
;; but keeps a fixed arity a nil-free struct rather than a phm.
|
||||
(if rst (assoc arity :rest rst) arity)))
|
||||
|
|
|
|||
|
|
@ -884,6 +884,27 @@
|
|||
;; jolt-41m: protocol-method registry "ns/method" -> [proto method], for
|
||||
;; devirtualizing a protocol call whose receiver is a known record type.
|
||||
(def ^:private protocol-methods-box (atom {}))
|
||||
|
||||
;; jolt-3ko: build a record's struct TYPE from its registry entry, resolving each
|
||||
;; field's declared type hint. A field tagged with a record type (its ctor-key)
|
||||
;; recurses, so a Vec3 stored in a Ray field reads back as Vec3 — not :any —
|
||||
;; which is what lets nested-record code prove its reads. Depth-bounded so a
|
||||
;; self/cyclic-referencing record type can't loop.
|
||||
(declare record-type-from-entry)
|
||||
(defn- field-type-from-tag [tag depth]
|
||||
(cond
|
||||
(or (nil? tag) (<= depth 0)) :any
|
||||
(= tag "num") :num
|
||||
:else (let [e (get @record-shapes-box tag)]
|
||||
(if e (record-type-from-entry e depth) :any))))
|
||||
(defn- record-type-from-entry [rs depth]
|
||||
(let [fields (get rs :fields)
|
||||
tags (get rs :tags)
|
||||
fmap (reduce (fn [m i]
|
||||
(assoc m (nth fields i)
|
||||
(field-type-from-tag (when tags (nth tags i)) (dec depth))))
|
||||
{} (range (count fields)))]
|
||||
(assoc (mk-struct fmap) :shape (vec fields) :type (get rs :type))))
|
||||
;; jolt-t34: whether to shape generic const-key MAP literals (opt-in, JOLT_SHAPE).
|
||||
;; Records are shaped regardless; maps only when this is on.
|
||||
(def ^:private map-shapes-box (atom false))
|
||||
|
|
@ -912,11 +933,10 @@
|
|||
(= op :var) (let [rs (get @record-shapes-box (var-key fnode))]
|
||||
(if rs
|
||||
;; record ctor -> struct of declared shape (jolt-t34); :shape
|
||||
;; is the DECLARED field order the back end indexes by, and
|
||||
;; :type is the record tag (for devirtualizing protocol calls)
|
||||
(let [fields (get rs :fields)]
|
||||
(assoc (mk-struct (reduce (fn [m k] (assoc m k :any)) {} fields))
|
||||
:shape (vec fields) :type (get rs :type)))
|
||||
;; is the DECLARED field order the back end indexes by, :type
|
||||
;; the record tag (devirt), and field types come from the
|
||||
;; declared hints so nested records stay typed (jolt-3ko)
|
||||
(record-type-from-entry rs type-depth)
|
||||
(let [r (get @rtenv-box (var-key fnode))]
|
||||
(if r r (let [nm (and (= "clojure.core" (get fnode :ns)) (get fnode :name))]
|
||||
(cond (nil? nm) :any
|
||||
|
|
@ -1405,7 +1425,20 @@
|
|||
(if (= :fn (get fnode :op))
|
||||
(assoc def-node :init
|
||||
(assoc fnode :arities
|
||||
(mapv (fn [a] (assoc a :body (nth (infer (get a :body) ptmap) 1)))
|
||||
(mapv (fn [a]
|
||||
;; seed declared record param hints (:phints, name ->
|
||||
;; ctor-key) so a record param is typed even with no
|
||||
;; inferred caller type — the open-world / cross-ns
|
||||
;; case. An inferred type in ptmap wins (it's at least
|
||||
;; as precise), so this only fills the gaps.
|
||||
(let [pt (reduce (fn [m pr]
|
||||
(let [nm (nth pr 0)
|
||||
e (get @record-shapes-box (nth pr 1))]
|
||||
(if (and e (not (contains? m nm)))
|
||||
(assoc m nm (record-type-from-entry e type-depth))
|
||||
m)))
|
||||
ptmap (get a :phints))]
|
||||
(assoc a :body (nth (infer (get a :body) pt) 1))))
|
||||
(get fnode :arities))))
|
||||
def-node)))
|
||||
|
||||
|
|
|
|||
|
|
@ -123,7 +123,24 @@
|
|||
(and (get (ctx :env) :direct-linking?)
|
||||
(not (cell :dynamic))
|
||||
(not (let [m (cell :meta)] (and m (get m :redef))))
|
||||
(function? (cell :root))))
|
||||
(let [r (cell :root)] (or (function? r) (cfunction? r)))))
|
||||
|
||||
# Whole-program constant-linking (closed world): under JOLT_WHOLE_PROGRAM every
|
||||
# non-dynamic var has a stable root we can embed as a CONSTANT, eliminating the
|
||||
# per-reference cell deref the indirect path pays. This covers what direct-var?
|
||||
# can't: ^:redef vars (no reloading under the flag, so redef is moot), data vars
|
||||
# (def of a number/vector/etc.), and record-type / non-fn callable roots. The
|
||||
# value is quoted at the emit site unless it's callable (a function/cfunction is
|
||||
# valid in head AND value position as-is). Dynamic vars stay indirect — thread
|
||||
# binding is a runtime mechanism, not redefinition. A nil root (a not-yet-run
|
||||
# forward def) stays indirect so the live deref picks the value up; the
|
||||
# whole-program re-emit (infer-program!, callee-first after full load) then
|
||||
# const-links it once its root is in place.
|
||||
(defn- const-link? [ctx cell]
|
||||
(and (get (ctx :env) :whole-program?)
|
||||
(get (ctx :env) :direct-linking?)
|
||||
(not (cell :dynamic))
|
||||
(not (nil? (cell :root)))))
|
||||
|
||||
# Fresh Janet symbol for back-end-introduced bindings (arity dispatch). NOT
|
||||
# Janet's `gensym` — `(use ./core)` shadows it with Jolt's, which returns a jolt
|
||||
|
|
@ -579,6 +596,13 @@
|
|||
:var (let [cell (cell-for ctx (node :ns) (node :name))]
|
||||
(if (direct-var? ctx cell)
|
||||
(cell :root) # direct link: embed the fn value
|
||||
(if (const-link? ctx cell)
|
||||
# whole-program closed world: embed the stable root as a constant.
|
||||
# Callable roots go in bare (valid in head/value position); any
|
||||
# other value is quoted so Janet returns it rather than evaluating
|
||||
# it as code (a bare tuple/struct in code position would be called).
|
||||
(let [r (cell :root)]
|
||||
(if (or (function? r) (cfunction? r)) r (tuple 'quote r)))
|
||||
# Indirect: live deref, with the var-get FN CALL inlined away
|
||||
# (jolt-8sq): a non-dynamic var's value is always its root, so
|
||||
# the common case is two native table ops + a branch instead of
|
||||
|
|
@ -597,7 +621,7 @@
|
|||
(let [qcell (tuple 'quote cell)]
|
||||
['if ['in qcell :dynamic]
|
||||
(tuple var-get qcell)
|
||||
['in qcell :root]])))
|
||||
['in qcell :root]]))))
|
||||
# (var x): the var object itself (not its value) — the embedded cell, by
|
||||
# reference. binding keys its thread-binding frame on this exact cell.
|
||||
:the-var (tuple 'quote (cell-for ctx (node :ns) (node :name)))
|
||||
|
|
|
|||
|
|
@ -1366,33 +1366,101 @@
|
|||
(when dc (each k (keys dc) (put dc k nil))))
|
||||
mm-var)
|
||||
|
||||
(defn- hint-cross-ns-key
|
||||
"Resolve a record-typed field hint (\"Vec3\", \"v/Vec3\", \"rt.vec/Vec3\") to the
|
||||
home namespace's ctor key (\"rt.vec/->Vec3\") when the type is defined in a
|
||||
DIFFERENT namespace and referred/aliased into the one being defined. The local
|
||||
current-ns/->Type lookup misses those; this resolves the hint name through the
|
||||
ns's :refer/:as bindings to the type var, then maps its root ctor value back to
|
||||
the home key via the ctor-value index. Using the ctor VALUE, not the var's :ns,
|
||||
is what makes :refer work — a :refer re-interns a fresh var whose :ns is the
|
||||
referring ns, but its root is the same shared ctor closure. nil if unresolved."
|
||||
[ctx t cix]
|
||||
# Resolve against the COMPILE ns (the user ns being analyzed), not ctx-current-ns
|
||||
# — during compilation the analyzer rebinds ctx-current-ns to jolt.analyzer, so a
|
||||
# bare referred name would otherwise miss. Qualified alias/Name resolves the alias
|
||||
# against the compile ns; a bare name looks up the compile ns's own mappings
|
||||
# (which include :refer-interned vars).
|
||||
(def cur-name (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx)))
|
||||
(def cur-ns (ctx-find-ns ctx cur-name))
|
||||
(def slash (string/find "/" t))
|
||||
(def v (when cur-ns
|
||||
(if slash
|
||||
(let [a (string/slice t 0 slash) nm (string/slice t (inc slash))
|
||||
home (or (ns-alias-lookup cur-ns a) (ns-import-lookup cur-ns a))]
|
||||
(when home (ns-find (ctx-find-ns ctx home) nm)))
|
||||
(ns-find cur-ns t))))
|
||||
(when (and v (table? v)) (get cix (v :root))))
|
||||
|
||||
(defn record-hint-ctor-key
|
||||
"Resolve a record-type hint NAME (as written on a ^Type field/param — bare,
|
||||
aliased, or fully qualified) to its home ctor key in the record-shapes registry
|
||||
(\"rt.vec/->Vec3\"), or nil if it is not a known record type. Local
|
||||
current-ns/->Name wins; otherwise cross-ns via the ctor-value index. Public so
|
||||
the analyzer (through jolt.host) can type a ^Type PARAM hint exactly as a field
|
||||
hint resolves, which is what carries a record param's type across a namespace
|
||||
boundary without whole-program inference."
|
||||
[ctx name]
|
||||
(def rs (get (ctx :env) :record-shapes))
|
||||
(when rs
|
||||
(def cur (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx)))
|
||||
(def local (string cur "/->" name))
|
||||
(if (get rs local)
|
||||
local
|
||||
(let [cix (get (ctx :env) :record-ctor-index)]
|
||||
(when cix (hint-cross-ns-key ctx name cix))))))
|
||||
|
||||
(defn make-deftype-ctor-impl
|
||||
"Build a deftype constructor closure. The ns-qualified type tag is baked at
|
||||
definition time (this runs during the deftype's (def …), in the type's ns), so
|
||||
instances carry a stable tag matching what extend-type registers methods under.
|
||||
field-kws is the [:f1 :f2 …] keyword vector; the ctor maps positional args to
|
||||
those keys. A ctx-capturing closure (make-deftype-ctor) is the public handle."
|
||||
[ctx type-name-sym field-kws]
|
||||
[ctx type-name-sym field-kws &opt field-tags]
|
||||
(def type-tag (string (ctx-current-ns ctx) "." (type-name-sym :name)))
|
||||
(def kws (d-realize field-kws))
|
||||
# per-field type hints (jolt-3ko): a tuple parallel to kws — "Vec3" (a record
|
||||
# type name), "num", or nil. The inference resolves these to the field's exact
|
||||
# type so reading a field back carries it (a nested record stays typed).
|
||||
(def tags (if field-tags (d-realize field-tags) (array/new-filled (length kws))))
|
||||
# The ctor closure itself. Built FIRST so it can be indexed by value below.
|
||||
# Records are shape-recs when shapes are active (:shapes? = direct-link, where
|
||||
# the inference proves the reads) — the whole field-access pipeline handles
|
||||
# them; otherwise the original :jolt/deftype tables. Read at ctor-BUILD time so
|
||||
# a type is consistently one representation or the other.
|
||||
(def the-ctor
|
||||
(if (get (ctx :env) :shapes?)
|
||||
(fn [& args] (make-record type-tag kws args))
|
||||
(fn [& args]
|
||||
(var inst @{:jolt/deftype type-tag})
|
||||
(var i 0) (each kw kws (put inst kw (in args i)) (++ i))
|
||||
inst)))
|
||||
# jolt-t34: register this record's ctor return shape (DECLARED field order) so
|
||||
# the inference types (->Name ...) as a struct of these fields and field reads
|
||||
# on the result bare-index. Keyed by the ctor var-key "ns/->Name" to match how
|
||||
# the IR names the call head. Harmless when records aren't shaped (sidx gated).
|
||||
(let [rs (or (get (ctx :env) :record-shapes)
|
||||
(let [t @{}] (put (ctx :env) :record-shapes t) t))]
|
||||
(let [t @{}] (put (ctx :env) :record-shapes t) t))
|
||||
# ctor-value index: maps each ctor closure to its rs key, so a ^Type hint
|
||||
# in another namespace can resolve home through the type var's root value
|
||||
# (jolt-3ko cross-ns hints; see hint-cross-ns-key).
|
||||
cix (or (get (ctx :env) :record-ctor-index)
|
||||
(let [t @{}] (put (ctx :env) :record-ctor-index t) t))
|
||||
# resolve a record-typed hint ("Vec3") to its ctor-key ("ns/->Vec3") so
|
||||
# the inference resolves it with a direct lookup. "num" stays as-is; a
|
||||
# local def wins; else try cross-ns resolution; an unresolved name (not a
|
||||
# known record type) stays bare -> :any.
|
||||
resolved (map (fn [t]
|
||||
(cond (nil? t) nil
|
||||
(= t "num") "num"
|
||||
(let [ck (string (ctx-current-ns ctx) "/->" t)]
|
||||
(if (get rs ck) ck
|
||||
(or (hint-cross-ns-key ctx t cix) t)))))
|
||||
tags)]
|
||||
(put rs (string (ctx-current-ns ctx) "/->" (type-name-sym :name))
|
||||
{:fields (tuple ;kws) :type type-tag}))
|
||||
# Records are shape-recs when shapes are active (:shapes? = direct-link, where
|
||||
# the inference proves the reads) — the whole field-access pipeline handles
|
||||
# them; otherwise the original :jolt/deftype tables. Read at ctor-BUILD time so
|
||||
# a type is consistently one representation or the other.
|
||||
(if (get (ctx :env) :shapes?)
|
||||
(fn [& args] (make-record type-tag kws args))
|
||||
(fn [& args]
|
||||
(var inst @{:jolt/deftype type-tag})
|
||||
(var i 0) (each kw kws (put inst kw (in args i)) (++ i))
|
||||
inst)))
|
||||
{:fields (tuple ;kws) :type type-tag :tags (tuple ;resolved)})
|
||||
(put cix the-ctor (string (ctx-current-ns ctx) "/->" (type-name-sym :name))))
|
||||
the-ctor)
|
||||
|
||||
(defn install-stateful-fns!
|
||||
"Intern ctx-capturing closures for the stateful primitives into clojure.core, so
|
||||
|
|
@ -1467,7 +1535,7 @@
|
|||
(ns-intern core "refer-clojure" (fn [& args] (refer-clojure-impl ctx ;args)))
|
||||
(ns-intern core "defmulti-setup" (fn [name-sym dispatch & opts] (defmulti-setup ctx name-sym dispatch ;opts)))
|
||||
(ns-intern core "defmethod-setup" (fn [mm-sym dval impl] (defmethod-setup ctx mm-sym dval impl)))
|
||||
(ns-intern core "make-deftype-ctor" (fn [name-sym field-kws] (make-deftype-ctor-impl ctx name-sym field-kws)))
|
||||
(ns-intern core "make-deftype-ctor" (fn [name-sym field-kws &opt field-tags] (make-deftype-ctor-impl ctx name-sym field-kws field-tags)))
|
||||
# Var/namespace lookups that need the ctx (the rest of the var fns — var-get/
|
||||
# var-set/var?/alter-var-root/alter-meta!/reset-meta! — are plain core-bindings).
|
||||
(ns-intern core "find-var" (fn [sym] (find-var ctx sym)))
|
||||
|
|
|
|||
|
|
@ -228,12 +228,16 @@
|
|||
# presence is the marker. Lets the analyzer resolve a ^Record type hint to the
|
||||
# struct fast path: record instances are tables tagged :jolt/deftype (NOT
|
||||
# :jolt/type), so a raw keyword get is correct for them (jolt-94n).
|
||||
(defn h-record-ctor-key [ctx name]
|
||||
# The home ctor key ("ns/->Name") for a ^Type hint, resolving cross-ns
|
||||
# (referred/aliased) records too — nil if `name` is not a known record type.
|
||||
(record-hint-ctor-key ctx name))
|
||||
|
||||
(defn h-record-type? [ctx name]
|
||||
(def ctor (string "->" name))
|
||||
(def cns (ctx-find-ns ctx (h-current-ns ctx)))
|
||||
(if (or (and cns (ns-find cns ctor))
|
||||
(ns-find (ctx-find-ns ctx "clojure.core") ctor))
|
||||
true false))
|
||||
# A ^Type hint names a record iff it resolves to a ctor key (local OR cross-ns,
|
||||
# via record-hint-ctor-key — so a referred/aliased foreign record is recognized,
|
||||
# not just one whose ->Name happens to be interned in the current ns).
|
||||
(if (record-hint-ctor-key ctx name) true false))
|
||||
|
||||
(def- exports
|
||||
{"form-sym?" h-sym? "form-sym-name" h-sym-name "form-sym-ns" h-sym-ns
|
||||
|
|
@ -250,7 +254,8 @@
|
|||
"form-syntax-quote-lower" h-syntax-quote-lower
|
||||
"host-intern!" h-intern!
|
||||
"inline-enabled?" h-inline-enabled? "inline-ir" h-inline-ir
|
||||
"record-type?" h-record-type? "form-position" h-form-position})
|
||||
"record-type?" h-record-type? "form-position" h-form-position
|
||||
"record-ctor-key" h-record-ctor-key})
|
||||
|
||||
(defn install! [ctx]
|
||||
(def ns (ctx-find-ns ctx "jolt.host"))
|
||||
|
|
|
|||
|
|
@ -613,7 +613,14 @@
|
|||
[meta-form]
|
||||
(cond
|
||||
(keyword? meta-form) {meta-form true}
|
||||
(and (struct? meta-form) (= :symbol (meta-form :jolt/type))) {:tag (meta-form :name)}
|
||||
# A symbol tag keeps its namespace qualifier (^t/Ray -> "t/Ray", not "Ray") so
|
||||
# an aliased/qualified record hint resolves through the ns's aliases the same
|
||||
# way a bare referred one does; dropping it silently mis-hinted across
|
||||
# namespaces. Bare symbols (^Ray, ^String) are unchanged.
|
||||
(and (struct? meta-form) (= :symbol (meta-form :jolt/type)))
|
||||
{:tag (if (meta-form :ns)
|
||||
(string (meta-form :ns) "/" (meta-form :name))
|
||||
(meta-form :name))}
|
||||
(string? meta-form) {:tag meta-form}
|
||||
nil))
|
||||
|
||||
|
|
|
|||
72
test/integration/cross-ns-hints-test.janet
Normal file
72
test/integration/cross-ns-hints-test.janet
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
# Cross-namespace ^Type field hints (jolt-3ko follow-up): a record field hinted
|
||||
# with a record type defined in ANOTHER namespace — referred (:refer) or aliased
|
||||
# (:as) in — must resolve to that type's HOME ctor key in the record-shapes
|
||||
# registry, the same as a same-namespace hint does. That resolved key is what
|
||||
# lets the inference type a field read back to the foreign record type instead of
|
||||
# :any (the lever for fast nested-record code across a multi-namespace program).
|
||||
# Guards both the :refer and :as spellings — for record FIELD hints and for
|
||||
# fn PARAM hints (which seed the inference so a record param's reads are typed
|
||||
# across a namespace boundary without whole-program). Also guards that the
|
||||
# reader keeps a tag's namespace qualifier (^g/Pt -> "g/Pt", not "Pt").
|
||||
(use ../../src/jolt/api)
|
||||
(import ../../src/jolt/types :as ty)
|
||||
(import ../../src/jolt/core :as jc)
|
||||
(import ../../src/jolt/reader :as rd)
|
||||
|
||||
(var failures 0)
|
||||
(defn- check [label got want]
|
||||
(unless (deep= got want)
|
||||
(++ failures)
|
||||
(printf "FAIL [%s] got %q want %q" label got want)))
|
||||
|
||||
(def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-xns-hints"))
|
||||
(os/mkdir dir)
|
||||
(os/mkdir (string dir "/geo"))
|
||||
# Pt lives in geo.pt; shape records in geo.shape hint ^Pt across the boundary.
|
||||
(spit (string dir "/geo/pt.clj")
|
||||
"(ns geo.pt)\n(defrecord Pt [x y z])\n")
|
||||
(spit (string dir "/geo/shape.clj")
|
||||
(string "(ns geo.shape (:require [geo.pt :as g :refer [Pt]]))\n"
|
||||
"(defrecord Seg [^Pt a ^Pt b])\n" # :refer field hint
|
||||
"(defrecord Tri [^g/Pt a ^g/Pt b ^g/Pt c])\n" # :as field hint
|
||||
# param hints, both spellings: ^Pt (referred), ^g/Pt (aliased)
|
||||
"(defn mid [^Pt a ^g/Pt b] a)\n"))
|
||||
|
||||
(def ctx (init {:compile? true :direct-linking? true}))
|
||||
(array/push (get (ctx :env) :source-paths) dir)
|
||||
(eval-string ctx "(require '[geo.shape])")
|
||||
(def rs (get (ctx :env) :record-shapes))
|
||||
|
||||
(check ":refer ^Pt field hint resolves to home ctor key"
|
||||
(get (get rs "geo.shape/->Seg") :tags)
|
||||
["geo.pt/->Pt" "geo.pt/->Pt"])
|
||||
(check ":as ^g/Pt field hint resolves to home ctor key"
|
||||
(get (get rs "geo.shape/->Tri") :tags)
|
||||
["geo.pt/->Pt" "geo.pt/->Pt" "geo.pt/->Pt"])
|
||||
# the foreign type's own shape is registered under its home key
|
||||
(check "home type registered"
|
||||
(get (get rs "geo.pt/->Pt") :fields)
|
||||
[:x :y :z])
|
||||
|
||||
# --- param hints: the arity carries [name ctor-key] for each record param, both
|
||||
# the :refer (^Pt) and :as (^g/Pt) spellings resolved to the home key ----------
|
||||
(def shape-ns (ty/ctx-find-ns ctx "geo.shape"))
|
||||
(def mid-ir (get (get (get shape-ns :mappings) "mid") :infer-ir))
|
||||
(def mid-arity (first (jc/vview (get (get mid-ir :init) :arities))))
|
||||
(def phints (when (get mid-arity :phints)
|
||||
(map jc/vview (jc/vview (get mid-arity :phints)))))
|
||||
(check "param hints resolve cross-ns (refer + as)"
|
||||
phints
|
||||
@[@["a" "geo.pt/->Pt"] @["b" "geo.pt/->Pt"]])
|
||||
|
||||
# --- reader keeps a tag's namespace qualifier ---------------------------------
|
||||
(check "reader preserves qualified tag ^g/Pt"
|
||||
(get (get (rd/parse-string "^g/Pt x") :meta) :tag)
|
||||
"g/Pt")
|
||||
(check "reader bare tag ^Pt unchanged"
|
||||
(get (get (rd/parse-string "^Pt x") :meta) :tag)
|
||||
"Pt")
|
||||
|
||||
(if (= 0 failures)
|
||||
(print "cross-ns-hints: all cases passed")
|
||||
(do (printf "cross-ns-hints: %d FAILURES" failures) (os/exit 1)))
|
||||
|
|
@ -13,10 +13,15 @@
|
|||
(spit (string dir "/wputil.clj")
|
||||
(string "(ns wputil)\n"
|
||||
"(defrecord V [x y z])\n"
|
||||
# const-link targets (jolt-rvt): a data def and a ^:redef fn are
|
||||
# indirect (cell deref) per-ns but embedded as constants under
|
||||
# whole-program. Soundness => both modes must give the same answer.
|
||||
"(def scale 2.0)\n"
|
||||
"(defn ^:redef bump [x] (+ x 1.0))\n"
|
||||
# recursive => never inlined; params proven only whole-program
|
||||
"(defn dot [a b n]\n"
|
||||
" (if (<= n 0) 0.0\n"
|
||||
" (+ (* (:x a) (:x b)) (* (:y a) (:y b)) (* (:z a) (:z b)) (dot a b (dec n)))))\n"))
|
||||
" (+ (* (:x a) (:x b)) (* (:y a) (:y b)) (* (:z a) (:z b)) (bump (* scale (dot a b (dec n)))))))\n"))
|
||||
(spit (string dir "/wpmain.clj")
|
||||
(string "(ns wpmain (:require [wputil :as v]))\n"
|
||||
"(defn -main []\n"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue