Address #1434 - add dynamic bindings for module state.

This commit is contained in:
Calvin Rose 2024-04-15 16:20:13 -05:00
parent 89e74dca3e
commit f92f3eb6fa
2 changed files with 32 additions and 19 deletions

View File

@ -2767,6 +2767,11 @@
(defn- check-is-dep [x] (unless (or (string/has-prefix? "/" x) (string/has-prefix? "@" x) (string/has-prefix? "." x)) x)) (defn- check-is-dep [x] (unless (or (string/has-prefix? "/" x) (string/has-prefix? "@" x) (string/has-prefix? "." x)) x))
(defn- check-project-relative [x] (if (string/has-prefix? "/" x) x)) (defn- check-project-relative [x] (if (string/has-prefix? "/" x) x))
(defdyn *module/cache* "Dynamic binding for overriding `module/cache`")
(defdyn *module/paths* "Dynamic binding for overriding `module/cache`")
(defdyn *module/loading* "Dynamic binding for overriding `module/cache`")
(defdyn *module/loaders* "Dynamic binding for overriding `module/loaders`")
(def module/cache (def module/cache
"A table, mapping loaded module identifiers to their environments." "A table, mapping loaded module identifiers to their environments."
@{}) @{})
@ -2795,24 +2800,25 @@
keyword name of a loader in `module/loaders`. Returns the modified `module/paths`. keyword name of a loader in `module/loaders`. Returns the modified `module/paths`.
``` ```
[ext loader] [ext loader]
(def mp (dyn *module/paths* module/paths))
(defn- find-prefix (defn- find-prefix
[pre] [pre]
(or (find-index |(and (string? ($ 0)) (string/has-prefix? pre ($ 0))) module/paths) 0)) (or (find-index |(and (string? ($ 0)) (string/has-prefix? pre ($ 0))) mp) 0))
(def dyn-index (find-prefix ":@all:")) (def dyn-index (find-prefix ":@all:"))
(array/insert module/paths dyn-index [(string ":@all:" ext) loader check-dyn-relative]) (array/insert mp dyn-index [(string ":@all:" ext) loader check-dyn-relative])
(def all-index (find-prefix ".:all:")) (def all-index (find-prefix ".:all:"))
(array/insert module/paths all-index [(string ".:all:" ext) loader check-project-relative]) (array/insert mp all-index [(string ".:all:" ext) loader check-project-relative])
(def sys-index (find-prefix ":sys:")) (def sys-index (find-prefix ":sys:"))
(array/insert module/paths sys-index [(string ":sys:/:all:" ext) loader check-is-dep]) (array/insert mp sys-index [(string ":sys:/:all:" ext) loader check-is-dep])
(def curall-index (find-prefix ":cur:/:all:")) (def curall-index (find-prefix ":cur:/:all:"))
(array/insert module/paths curall-index [(string ":cur:/:all:" ext) loader check-relative]) (array/insert mp curall-index [(string ":cur:/:all:" ext) loader check-relative])
module/paths) mp)
(module/add-paths ":native:" :native) (module/add-paths ":native:" :native)
(module/add-paths "/init.janet" :source) (module/add-paths "/init.janet" :source)
(module/add-paths ".janet" :source) (module/add-paths ".janet" :source)
(module/add-paths ".jimage" :image) (module/add-paths ".jimage" :image)
(array/insert module/paths 0 [(fn is-cached [path] (if (in module/cache path) path)) :preload check-not-relative]) (array/insert module/paths 0 [(fn is-cached [path] (if (in (dyn *module/cache* module/cache) path) path)) :preload check-not-relative])
# Version of fexists that works even with a reduced OS # Version of fexists that works even with a reduced OS
(defn- fexists (defn- fexists
@ -2842,7 +2848,8 @@
``` ```
[path] [path]
(var ret nil) (var ret nil)
(each [p mod-kind checker] module/paths (def mp (dyn *module/paths* module/paths))
(each [p mod-kind checker] mp
(when (mod-filter checker path) (when (mod-filter checker path)
(if (function? p) (if (function? p)
(when-let [res (p path)] (when-let [res (p path)]
@ -2858,7 +2865,7 @@
(when (string? t) (when (string? t)
(when (mod-filter chk path) (when (mod-filter chk path)
(module/expand-path path t)))) (module/expand-path path t))))
paths (filter identity (map expander module/paths)) paths (filter identity (map expander mp))
str-parts (interpose "\n " paths)] str-parts (interpose "\n " paths)]
[nil (string "could not find module " path ":\n " ;str-parts)]))) [nil (string "could not find module " path ":\n " ;str-parts)])))
@ -3013,13 +3020,15 @@
of files as modules.`` of files as modules.``
@{:native (fn native-loader [path &] (native path (make-env))) @{:native (fn native-loader [path &] (native path (make-env)))
:source (fn source-loader [path args] :source (fn source-loader [path args]
(put module/loading path true) (def ml (dyn *module/loading* module/loading))
(defer (put module/loading path nil) (put ml path true)
(defer (put ml path nil)
(dofile path ;args))) (dofile path ;args)))
:preload (fn preload-loader [path & args] :preload (fn preload-loader [path & args]
(when-let [m (in module/cache path)] (def mc (dyn *module/cache* module/cache))
(when-let [m (in mc path)]
(if (function? m) (if (function? m)
(set (module/cache path) (m path ;args)) (set (mc path) (m path ;args))
m))) m)))
:image (fn image-loader [path &] (load-image (slurp path)))}) :image (fn image-loader [path &] (load-image (slurp path)))})
@ -3027,15 +3036,18 @@
[path args kargs] [path args kargs]
(def [fullpath mod-kind] (module/find path)) (def [fullpath mod-kind] (module/find path))
(unless fullpath (error mod-kind)) (unless fullpath (error mod-kind))
(if-let [check (if-not (kargs :fresh) (in module/cache fullpath))] (def mc (dyn *module/cache* module/cache))
(def ml (dyn *module/loading* module/loading))
(def mls (dyn *module/loaders* module/loaders))
(if-let [check (if-not (kargs :fresh) (in mc fullpath))]
check check
(if (module/loading fullpath) (if (ml fullpath)
(error (string "circular dependency " fullpath " detected")) (error (string "circular dependency " fullpath " detected"))
(do (do
(def loader (if (keyword? mod-kind) (module/loaders mod-kind) mod-kind)) (def loader (if (keyword? mod-kind) (mls mod-kind) mod-kind))
(unless loader (error (string "module type " mod-kind " unknown"))) (unless loader (error (string "module type " mod-kind " unknown")))
(def env (loader fullpath args)) (def env (loader fullpath args))
(put module/cache fullpath env) (put mc fullpath env)
env)))) env))))
(defn require (defn require

View File

@ -1595,7 +1595,7 @@ JANET_CORE_FN(os_clock,
struct timespec tv; struct timespec tv;
if (janet_gettime(&tv, source)) janet_panic("could not get time"); if (janet_gettime(&tv, source)) janet_panic("could not get time");
JanetKeyword formatstr = janet_optkeyword(argv, argc, 1 , (const uint8_t *) "double"); JanetKeyword formatstr = janet_optkeyword(argv, argc, 1, (const uint8_t *) "double");
if (janet_cstrcmp(formatstr, "double") == 0) { if (janet_cstrcmp(formatstr, "double") == 0) {
double dtime = tv.tv_sec + (tv.tv_nsec / 1E9); double dtime = tv.tv_sec + (tv.tv_nsec / 1E9);
return janet_wrap_number(dtime); return janet_wrap_number(dtime);
@ -1603,7 +1603,8 @@ JANET_CORE_FN(os_clock,
return janet_wrap_number(tv.tv_sec); return janet_wrap_number(tv.tv_sec);
} else if (janet_cstrcmp(formatstr, "tuple") == 0) { } else if (janet_cstrcmp(formatstr, "tuple") == 0) {
Janet tup[2] = {janet_wrap_integer(tv.tv_sec), Janet tup[2] = {janet_wrap_integer(tv.tv_sec),
janet_wrap_integer(tv.tv_nsec)}; janet_wrap_integer(tv.tv_nsec)
};
return janet_wrap_tuple(janet_tuple_n(tup, 2)); return janet_wrap_tuple(janet_tuple_n(tup, 2));
} else { } else {
janet_panicf("expected :double, :int, or :tuple, got %v", argv[1]); janet_panicf("expected :double, :int, or :tuple, got %v", argv[1]);