From 93fb4379ffff17b0d20cf0bf5edd34d46ec90e88 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Thu, 23 Dec 2021 21:23:11 +0100 Subject: [PATCH] [#584, #1037] Uberscript in bb (#1115) --- sci | 2 +- src/babashka/impl/uberscript.clj | 105 +++++ src/babashka/main.clj | 429 +++++++++--------- .../babashka/uberscript/src/my/impl1.clj | 15 +- test/babashka/test_utils.clj | 4 +- test/babashka/uberscript_test.clj | 23 +- 6 files changed, 358 insertions(+), 220 deletions(-) create mode 100644 src/babashka/impl/uberscript.clj diff --git a/sci b/sci index 6ad100c7..f29089b6 160000 --- a/sci +++ b/sci @@ -1 +1 @@ -Subproject commit 6ad100c7376bfac0f58ac12576caa805e2026d33 +Subproject commit f29089b68e2e7d41e9491be0c1d7c48e1b9691e7 diff --git a/src/babashka/impl/uberscript.clj b/src/babashka/impl/uberscript.clj new file mode 100644 index 00000000..332f88b0 --- /dev/null +++ b/src/babashka/impl/uberscript.clj @@ -0,0 +1,105 @@ +(ns babashka.impl.uberscript + (:require [sci.core :as sci])) + +(defn decompose-clause [clause] + (if (symbol? clause) + {:ns clause} + (when (seqable? clause) + (let [clause (if (= 'quote (first clause)) + (second clause) + clause) + [ns & tail] clause] + (loop [parsed {:ns ns} + tail (seq tail)] + (if tail + (let [ftail (first tail)] + (case ftail + :as (recur (assoc parsed :as (second tail)) + (nnext tail)) + :refer + (let [refer (second tail)] + (if (seqable? refer) + (recur (assoc parsed :refer (second tail)) + (nnext tail)) + (recur parsed (nnext tail)))) + ;; default + (recur parsed + (nnext tail)))) + parsed)))))) + +(defn recompose-clause [{:keys [:ns :as]}] + [ns :as as]) + +(defn process-ns + [_ctx ns] + (keep (fn [x] + (if (seqable? x) + (let [fx (first x)] + (when (identical? :require fx) + (let [decomposed (keep decompose-clause (rest x)) + recomposed (map recompose-clause decomposed)] + (list* :require recomposed)))) + x)) + ns)) + +(defn keep-quoted [clauses] + (keep (fn [clause] + (when (and (seq? clause) (= 'quote (first clause))) + (second clause))) + clauses)) + +(defn process-require [_ctx req] + (let [quoted (keep-quoted (rest req)) + decomposed (map decompose-clause quoted)] + (list* 'require (map (fn [clause] + (list 'quote (recompose-clause clause))) + decomposed)))) + +(defn process-in-ns [_ctx req] + (let [quoted (keep-quoted (rest req)) + quoted (map (fn [ns] + (list 'quote ns)) + quoted)] + (when (clojure.core/seq quoted) + (list* 'in-ns quoted)))) + +(defn loc [rdr] + (str (when-let [f @sci/file] + (str f ":")) + (sci/get-line-number rdr) + ":" + (sci/get-column-number rdr))) + +(defn uberscript [{:keys [ctx expressions]}] + (let [ctx (assoc ctx :reload-all true)] + (sci/binding [sci/file @sci/file] + (doseq [expr expressions] + (let [rdr (sci/reader expr)] + (loop [] + (let [next-val + (try (sci/parse-next ctx rdr) + ;; swallow reader error + (catch Exception _e + (binding [*out* *err*] + (println "[babashka]" "Ignoring read error while assembling uberscript near" + (loc rdr)))))] + ;; (.println System/err (pr-str next-val)) + (when-not (= ::sci/eof next-val) + (if (seq? next-val) + (let [fst (first next-val) + expr (cond (= 'ns fst) + (process-ns ctx next-val) + (= 'require fst) + (process-require ctx next-val) + (= 'in-ns fst) + (process-in-ns ctx next-val))] + (when expr + (try + (sci/eval-form ctx expr) + ;; swallow exception and continue + (catch Exception _e + (binding [*out* *err*] + (println "[babashka]" "Ignoring expression while assembling uberscript:" + expr "near" (loc rdr)))))) + (recur)) + (recur)))))))))) diff --git a/src/babashka/main.clj b/src/babashka/main.clj index 2a1ed381..6dde9961 100644 --- a/src/babashka/main.clj +++ b/src/babashka/main.clj @@ -41,6 +41,7 @@ [babashka.impl.tasks :as tasks :refer [tasks-namespace]] [babashka.impl.test :as t] [babashka.impl.tools.cli :refer [tools-cli-namespace]] + [babashka.impl.uberscript :as uberscript] [babashka.nrepl.server :as nrepl-server] [babashka.wait :refer [wait-namespace]] [clojure.edn :as edn] @@ -272,8 +273,8 @@ Use bb run --help to show this help output. (let [f (io/file file)] (if (.exists f) (as-> (slurp file) x - ;; remove shebang - (str/replace x #"^#!.*" "")) + ;; remove shebang + (str/replace x #"^#!.*" "")) (throw (Exception. (str "File does not exist: " file)))))) (defn load-file* [f] @@ -727,9 +728,13 @@ Use bb run --help to show this help output. (or (contains? namespaces namespace) (contains? sci-namespaces/namespaces namespace))) "" - (let [res (cp/source-for-namespace loader namespace nil)] - (when uberscript (swap! uberscript-sources conj (:source res))) - res))) + (when-let [res (cp/source-for-namespace loader namespace nil)] + (if uberscript + (do (swap! uberscript-sources conj (:source res)) + (uberscript/uberscript {:ctx @common/ctx + :expressions [(:source res)]}) + {}) + res)))) (case namespace clojure.spec.alpha (binding [*out* *err*] @@ -738,224 +743,228 @@ Use bb run --help to show this help output. (binding [*out* *err*] (println "[babashka] WARNING: clojure.core.specs.alpha is removed from the classpath, unless you explicitly add the dependency.")) nil))) - main (if (and jar (not main)) - (when-let [res (cp/getResource - (cp/loader jar) - ["META-INF/MANIFEST.MF"] {:url? true})] - (cp/main-ns res)) - main) - ;; TODO: pull more of these values to compile time - opts {:aliases aliases - :namespaces (-> namespaces - (assoc 'clojure.core - (assoc core-extras - 'load-file (sci-namespaces/core-var 'load-file load-file*)))) - :env env - :features #{:bb :clj} - :classes classes/class-map - :imports classes/imports - :load-fn load-fn - :uberscript uberscript - ;; :readers core/data-readers - :reify-fn reify-fn - :proxy-fn proxy-fn} - opts (addons/future opts) - sci-ctx (sci/init opts) - _ (vreset! common/ctx sci-ctx) - preloads (some-> (System/getenv "BABASHKA_PRELOADS") (str/trim)) - [expressions exit-code] - (cond expressions [expressions nil] - main - (let [sym (symbol main) - ns? (namespace sym) - ns (or ns? sym) - var-name (if ns? - (name sym) - "-main")] - [[(format "(ns user (:require [%1$s])) (apply %1$s/%2$s *command-line-args*)" - ns var-name)] nil]) - run (if (:run-help cli-opts) - [(print-run-help) 0] - (do - (System/setProperty "babashka.task" (str run)) - (tasks/assemble-task run - (:parallel-tasks cli-opts)))) - file (try [[(read-file file)] nil] - (catch Exception e - (error-handler e {:expression expressions - :debug debug - :preloads preloads - :init init - :loader (:loader @cp/cp-state)})))) - expression (str/join " " expressions) ;; this might mess with the locations... - exit-code - ;; handle preloads - (if exit-code exit-code - (do (when preloads - (sci/binding [sci/file ""] - (try - (sci/eval-string* sci-ctx preloads) - (catch Throwable e - (error-handler e {:expression expression - :debug debug - :preloads preloads - :init init - :loader (:loader @cp/cp-state)}))))) - nil)) - exit-code - ;; handle --init - (if exit-code exit-code - (do (when init - (try - (load-file* init) - (catch Throwable e - (error-handler e {:expression expression - :debug debug - :preloads preloads - :init init - :loader (:loader @cp/cp-state)})))) - nil)) - ;; socket REPL is start asynchronously. when no other args are - ;; provided, a normal REPL will be started as well, which causes the - ;; process to wait until SIGINT - _ (when socket-repl (start-socket-repl! socket-repl sci-ctx)) - exit-code - (or exit-code - (second - (cond version-opt - [(print-version) 0] - help (print-help sci-ctx command-line-args) - doc (print-doc sci-ctx command-line-args) - describe? - [(print-describe) 0] - repl [(repl/start-repl! sci-ctx) 0] - nrepl [(start-nrepl! nrepl sci-ctx) 0] - uberjar [nil 0] - list-tasks [(tasks/list-tasks sci-ctx) 0] - print-deps [(print-deps/print-deps (:print-deps-format cli-opts)) 0] - expressions - (sci/binding [sci/file abs-path] - (try + main (if (and jar (not main)) + (when-let [res (cp/getResource + (cp/loader jar) + ["META-INF/MANIFEST.MF"] {:url? true})] + (cp/main-ns res)) + main) + ;; TODO: pull more of these values to compile time + opts {:aliases aliases + :namespaces (-> namespaces + (assoc 'clojure.core + (assoc core-extras + 'load-file (sci-namespaces/core-var 'load-file load-file*)))) + :env env + :features #{:bb :clj} + :classes classes/class-map + :imports classes/imports + :load-fn load-fn + :uberscript uberscript + ;; :readers core/data-readers + :reify-fn reify-fn + :proxy-fn proxy-fn} + opts (addons/future opts) + sci-ctx (sci/init opts) + _ (vreset! common/ctx sci-ctx) + preloads (some-> (System/getenv "BABASHKA_PRELOADS") (str/trim)) + [expressions exit-code] + (cond expressions [expressions nil] + main + (let [sym (symbol main) + ns? (namespace sym) + ns (or ns? sym) + var-name (if ns? + (name sym) + "-main")] + [[(format "(ns user (:require [%1$s])) (apply %1$s/%2$s *command-line-args*)" + ns var-name)] nil]) + run (if (:run-help cli-opts) + [(print-run-help) 0] + (do + (System/setProperty "babashka.task" (str run)) + (tasks/assemble-task run + (:parallel-tasks cli-opts)))) + file (try [[(read-file file)] nil] + (catch Exception e + (error-handler e {:expression expressions + :debug debug + :preloads preloads + :init init + :loader (:loader @cp/cp-state)})))) + expression (str/join " " expressions) ;; this might mess with the locations... + exit-code + ;; handle preloads + (if exit-code exit-code + (do (when preloads + (sci/binding [sci/file ""] + (try + (sci/eval-string* sci-ctx preloads) + (catch Throwable e + (error-handler e {:expression expression + :debug debug + :preloads preloads + :init init + :loader (:loader @cp/cp-state)}))))) + nil)) + exit-code + ;; handle --init + (if exit-code exit-code + (do (when init + (try + (load-file* init) + (catch Throwable e + (error-handler e {:expression expression + :debug debug + :preloads preloads + :init init + :loader (:loader @cp/cp-state)})))) + nil)) + ;; socket REPL is start asynchronously. when no other args are + ;; provided, a normal REPL will be started as well, which causes the + ;; process to wait until SIGINT + _ (when socket-repl (start-socket-repl! socket-repl sci-ctx)) + exit-code + (or exit-code + (second + (cond version-opt + [(print-version) 0] + help (print-help sci-ctx command-line-args) + doc (print-doc sci-ctx command-line-args) + describe? + [(print-describe) 0] + repl [(repl/start-repl! sci-ctx) 0] + nrepl [(start-nrepl! nrepl sci-ctx) 0] + uberjar [nil 0] + list-tasks [(tasks/list-tasks sci-ctx) 0] + print-deps [(print-deps/print-deps (:print-deps-format cli-opts)) 0] + uberscript + [nil (do (uberscript/uberscript {:ctx sci-ctx + :expressions expressions}) + 0)] + expressions + ;; execute code + (sci/binding [sci/file abs-path] + (try ; when evaluating expression(s), add in repl-requires so things like ; pprint and dir are available - (sci/eval-form sci-ctx `(apply require (quote ~clojure-main/repl-requires))) - (loop [] - (let [in (read-next *in*)] - (if (identical? ::EOF in) - [nil 0] ;; done streaming - (let [res [(let [res - (sci/binding [sci/file (or @sci/file "") - input-var in - core/command-line-args command-line-args] - (sci/eval-string* sci-ctx expression))] - ;; return value printing - (when (and (some? res) - (or (not run) - (:prn cli-opts))) - (if-let [pr-f (cond shell-out println - edn-out prn)] - (if (sequential? res) - (doseq [l res - :while (not (pipe-signal-received?))] - (pr-f l)) - (pr-f res)) - (prn res)))) 0]] - (if stream? - (recur) - res))))) - (catch Throwable e - (error-handler e {:expression expression - :debug debug - :preloads preloads - :loader (:loader @cp/cp-state)})))) - clojure [nil (if-let [proc (bdeps/clojure command-line-args)] - (-> @proc :exit) - 0)] - uberscript [nil 0] - :else [(repl/start-repl! sci-ctx) 0])) - 1)] - (flush) - (when uberscript - (let [uberscript-out uberscript] - (spit uberscript-out "") ;; reset file - (doseq [s (distinct @uberscript-sources)] - (spit uberscript-out s :append true)) - (spit uberscript-out preloads :append true) - (spit uberscript-out expression :append true))) - (when uberjar - (if-let [cp (cp/get-classpath)] - (uberjar/run {:dest uberjar - :jar :uber - :classpath cp - :main-class main - :verbose debug}) - (throw (Exception. "The uberjar task needs a classpath.")))) - exit-code)))) + (sci/eval-form sci-ctx `(apply require (quote ~clojure-main/repl-requires))) + (loop [] + (let [in (read-next *in*)] + (if (identical? ::EOF in) + [nil 0] ;; done streaming + (let [res [(let [res + (sci/binding [sci/file (or @sci/file "") + input-var in + core/command-line-args command-line-args] + (sci/eval-string* sci-ctx expression))] + ;; return value printing + (when (and (some? res) + (or (not run) + (:prn cli-opts))) + (if-let [pr-f (cond shell-out println + edn-out prn)] + (if (sequential? res) + (doseq [l res + :while (not (pipe-signal-received?))] + (pr-f l)) + (pr-f res)) + (prn res)))) 0]] + (if stream? + (recur) + res))))) + (catch Throwable e + (error-handler e {:expression expression + :debug debug + :preloads preloads + :loader (:loader @cp/cp-state)})))) + clojure [nil (if-let [proc (bdeps/clojure command-line-args)] + (-> @proc :exit) + 0)] + :else [(repl/start-repl! sci-ctx) 0])) + 1)] + (flush) + (when uberscript + (let [uberscript-out uberscript] + (spit uberscript-out "") ;; reset file + (doseq [s (distinct @uberscript-sources)] + (spit uberscript-out s :append true)) + (spit uberscript-out preloads :append true) + (spit uberscript-out expression :append true))) + (when uberjar + (if-let [cp (cp/get-classpath)] + (uberjar/run {:dest uberjar + :jar :uber + :classpath cp + :main-class main + :verbose debug}) + (throw (Exception. "The uberjar task needs a classpath.")))) + exit-code)))) (defn satisfies-min-version? [min-version] - (let [[major-current minor-current patch-current] version-data - [major-min minor-min patch-min] (parse-version min-version)] - (or (> major-current major-min) - (and (= major-current major-min) - (or (> minor-current minor-min) - (and (= minor-current minor-min) - (>= patch-current patch-min))))))) +(let [[major-current minor-current patch-current] version-data + [major-min minor-min patch-min] (parse-version min-version)] +(or (> major-current major-min) + (and (= major-current major-min) + (or (> minor-current minor-min) + (and (= minor-current minor-min) + (>= patch-current patch-min))))))) (defn main [& args] - (let [bb-edn-file (or (System/getenv "BABASHKA_EDN") - "bb.edn") - bb-edn (or (when (fs/exists? bb-edn-file) - (let [raw-string (slurp bb-edn-file) - edn (edn/read-string raw-string) - edn (assoc edn :raw raw-string)] - (vreset! common/bb-edn edn))) - ;; tests may have modified bb-edn - @common/bb-edn) - min-bb-version (:min-bb-version bb-edn)] - (when min-bb-version - (when-not (satisfies-min-version? min-bb-version) - (binding [*out* *err*] - (println (str "WARNING: this project requires babashka " - min-bb-version " or newer, but you have: " version)))))) - (let [opts (parse-opts args)] - (exec opts))) +(let [bb-edn-file (or (System/getenv "BABASHKA_EDN") + "bb.edn") + bb-edn (or (when (fs/exists? bb-edn-file) + (let [raw-string (slurp bb-edn-file) + edn (edn/read-string raw-string) + edn (assoc edn :raw raw-string)] + (vreset! common/bb-edn edn))) + ;; tests may have modified bb-edn + @common/bb-edn) + min-bb-version (:min-bb-version bb-edn)] +(when min-bb-version + (when-not (satisfies-min-version? min-bb-version) + (binding [*out* *err*] + (println (str "WARNING: this project requires babashka " + min-bb-version " or newer, but you have: " version)))))) +(let [opts (parse-opts args)] +(exec opts))) (def musl? - "Captured at compile time, to know if we are running inside a +"Captured at compile time, to know if we are running inside a statically compiled executable with musl." - (and (= "true" (System/getenv "BABASHKA_STATIC")) - (= "true" (System/getenv "BABASHKA_MUSL")))) +(and (= "true" (System/getenv "BABASHKA_STATIC")) +(= "true" (System/getenv "BABASHKA_MUSL")))) (defmacro run [args] - (if musl? - ;; When running in musl-compiled static executable we lift execution of bb - ;; inside a thread, so we have a larger than default stack size, set by an - ;; argument to the linker. See https://github.com/oracle/graal/issues/3398 - `(let [v# (volatile! nil) - f# (fn [] - (vreset! v# (apply main ~args)))] - (doto (Thread. nil f# "main") - (.start) - (.join)) - @v#) - `(apply main ~args))) +(if musl? +;; When running in musl-compiled static executable we lift execution of bb +;; inside a thread, so we have a larger than default stack size, set by an +;; argument to the linker. See https://github.com/oracle/graal/issues/3398 +`(let [v# (volatile! nil) + f# (fn [] + (vreset! v# (apply main ~args)))] + (doto (Thread. nil f# "main") + (.start) + (.join)) + @v#) +`(apply main ~args))) (defn -main - [& args] - (handle-pipe!) - (handle-sigint!) - (if-let [dev-opts (System/getenv "BABASHKA_DEV")] - (let [{:keys [:n]} (if (= "true" dev-opts) {:n 1} - (edn/read-string dev-opts)) - last-iteration (dec n)] - (dotimes [i n] - (if (< i last-iteration) - (with-out-str (apply main args)) - (do (run args) - (binding [*out* *err*] - (println "ran" n "times")))))) - (let [exit-code (run args)] - (System/exit exit-code)))) +[& args] +(handle-pipe!) +(handle-sigint!) +(if-let [dev-opts (System/getenv "BABASHKA_DEV")] +(let [{:keys [:n]} (if (= "true" dev-opts) {:n 1} + (edn/read-string dev-opts)) + last-iteration (dec n)] + (dotimes [i n] + (if (< i last-iteration) + (with-out-str (apply main args)) + (do (run args) + (binding [*out* *err*] + (println "ran" n "times")))))) +(let [exit-code (run args)] + (System/exit exit-code)))) ;;;; Scratch diff --git a/test-resources/babashka/uberscript/src/my/impl1.clj b/test-resources/babashka/uberscript/src/my/impl1.clj index 36aff679..d51ca942 100644 --- a/test-resources/babashka/uberscript/src/my/impl1.clj +++ b/test-resources/babashka/uberscript/src/my/impl1.clj @@ -1,5 +1,18 @@ (ns my.impl1 - (:require [clojure.string])) + (:require [babashka.pods :as pods] + [clojure.string :as str])) + +;; uberscript parser can parse and skip this +(prn ::str/foo) +str/join + +(alias 'a 'clojure.string) +::a/foo ;; no error either + +(pods/load-pod 'clj-kondo/clj-kondo "2021.10.19") +(require '[pod.borkdude.clj-kondo :as clj-kondo]) + +(prn (some? clj-kondo/run!)) (defn impl-fn "identity" diff --git a/test/babashka/test_utils.clj b/test/babashka/test_utils.clj index 029b6f52..3b086746 100644 --- a/test/babashka/test_utils.clj +++ b/test/babashka/test_utils.clj @@ -75,7 +75,9 @@ (with-in-str input-or-opts (apply main/main args)) (apply main/main args)))] (if (zero? res) - (normalize (str os)) + (do + (println (str es)) ;; flush stderr + (normalize (str os))) (do (println (str os)) (throw (ex-info (str es) diff --git a/test/babashka/uberscript_test.clj b/test/babashka/uberscript_test.clj index b7d39683..4fbc1af8 100644 --- a/test/babashka/uberscript_test.clj +++ b/test/babashka/uberscript_test.clj @@ -1,16 +1,25 @@ (ns babashka.uberscript-test (:require [babashka.test-utils :as tu] - [clojure.test :as t :refer [deftest is testing]])) + [clojure.test :as t :refer [deftest is]])) -(deftest uberscript-test +(deftest basic-test (let [tmp-file (java.io.File/createTempFile "uberscript" ".clj")] (.deleteOnExit tmp-file) - (is (empty? (tu/bb nil "--classpath" "test-resources/babashka/src_for_classpath_test" "uberscript" (.getPath tmp-file) "-m" "my.main" ))) + (is (empty? (tu/bb nil "--classpath" "test-resources/babashka/src_for_classpath_test" "uberscript" (.getPath tmp-file) "-m" "my.main"))) (is (= "(\"1\" \"2\" \"3\" \"4\")\n" - (tu/bb nil "--file" (.getPath tmp-file) "1" "2" "3" "4"))) - (testing "order of namespaces is correct" - (tu/bb nil "--classpath" "test-resources/babashka/uberscript/src" "uberscript" (.getPath tmp-file) "-m" "my.main") - (is (= "(\"1\" \"2\" \"3\" \"4\")\n" + (tu/bb nil "--file" (.getPath tmp-file) "1" "2" "3" "4"))))) + +(when-not (= "aarch64" (System/getenv "BABASHKA_ARCH")) + (deftest advanced-test + (let [tmp-file (java.io.File/createTempFile "uberscript" ".clj")] + (.deleteOnExit tmp-file) + ;; we test: + ;; order of namespaces + ;; reader error for ::a/foo is swallowed + ;; pod namespaces can be loaded without a problem + ;; resulting program can be executed + (is (empty? (tu/bb nil "--classpath" "test-resources/babashka/uberscript/src" "uberscript" (.getPath tmp-file) "-m" "my.main"))) + (is (= ":clojure.string/foo\ntrue\n(\"1\" \"2\" \"3\" \"4\")\n" (tu/bb nil "--file" (.getPath tmp-file) "1" "2" "3" "4"))))))