(.require [library [lux (.except) [program (.only program)] ["[0]" ffi (.only import)] ["[0]" debug] [abstract [monad (.only do)]] [control ["[0]" maybe (.use "[1]#[0]" monad)] ["[0]" try (.only Try)] ["[0]" exception (.only Exception)] ["[0]" io (.only IO io)] ["[0]" function] [concurrency ["[0]" async (.only Async)]]] [data ["[0]" product] [text ["%" \\format (.only format)] [encoding ["[0]" utf8]]] [collection ["[0]" array (.only Array)]]] [math [number ["n" nat] ["i" int] ["[0]" i64]]] ["[0]" world ["[0]" file] ["[1]/[0]" environment]] [meta ["@" target (.only) ["_" js]] [macro ["^" pattern] ["[0]" template]] [compiler ["[0]" phase (.only Operation Phase)] [reference [variable (.only Register)]] [language [lux [program (.only Program)] [translation (.only Host)] [analysis [macro (.only Expander)]] [phase ["[0]" extension (.only Extender Handler) ["[0]" analysis ["[1]" js]] ["[0]" translation ["[1]" js]]] [translation ["[0]" reference] ["[0]" js (.only) ["[0]" runtime] ["[1]/[0]" reference]]]]]] [default ["[0]" platform (.only Platform)]] [meta ["[0]" cli] ["[0]" context] [archive (.only Archive) ["[0]" unit]] ["[0]" packager ["[1]" script]]]]]]] [program ["/" compositor]]) (exception.def (null_has_no_lux_representation code) (Exception (Maybe _.Expression)) (when code {.#Some code} (_.code code) {.#None} "???")) (for @.jvm (these (import java/lang/String "[1]::[0]") (import (java/lang/Class a) "[1]::[0]") (import java/lang/Object "[1]::[0]" (toString [] java/lang/String) (getClass [] (java/lang/Class java/lang/Object))) (import java/lang/Long "[1]::[0]" (intValue [] int)) (import java/lang/Integer "[1]::[0]" (longValue [] long)) (import java/lang/Number "[1]::[0]" (intValue [] int) (longValue [] long) (doubleValue [] double)) (import java/util/Arrays "[1]::[0]" ("static" [t] copyOfRange [[t] int int] [t])) (import javax/script/ScriptEngine "[1]::[0]" (eval [java/lang/String] "try" "?" java/lang/Object)) (import javax/script/ScriptEngineFactory "[1]::[0]" (getScriptEngine [] javax/script/ScriptEngine)) (import org/openjdk/nashorn/api/scripting/NashornScriptEngineFactory "[1]::[0]" (new [])) (import org/openjdk/nashorn/api/scripting/JSObject "[1]::[0]" (isArray [] boolean) (isFunction [] boolean) (getSlot [int] "?" java/lang/Object) (getMember [java/lang/String] "?" java/lang/Object) (hasMember [java/lang/String] boolean) (call ["?" java/lang/Object [java/lang/Object]] "try" java/lang/Object)) (import org/openjdk/nashorn/api/scripting/AbstractJSObject "[1]::[0]") (import org/openjdk/nashorn/api/scripting/ScriptObjectMirror "[1]::[0]" (size [] int) (toString [] java/lang/String) (getOwnKeys [boolean] [java/lang/String])) (import org/openjdk/nashorn/internal/runtime/Undefined "[1]::[0]") (with_template [] [(ffi.interface (getValue [] java/lang/Object)) (import "[1]::[0]" (getValue [] java/lang/Object))] [IntValue] [StructureValue] ) (exception.def (unknown_member [member object]) (Exception [Text java/lang/Object]) (exception.report (list ["Member" member] ["Object" (debug.inspection object)]))) (def jvm_int (-> (I64 Any) java/lang/Integer) (|>> .int ffi.as_long java/lang/Long::intValue)) (def (js_int value) (-> Int org/openjdk/nashorn/api/scripting/JSObject) (<| (ffi.is org/openjdk/nashorn/api/scripting/JSObject) (ffi.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject [IntValue] [] ... Methods (IntValue [] (getValue self []) java/lang/Object (ffi.is java/lang/Object (ffi.as_long value))) (org/openjdk/nashorn/api/scripting/AbstractJSObject [] (getMember self [member java/lang/String]) java/lang/Object (when (ffi.of_string member) runtime.i64_high_field (|> value .nat runtime.high jvm_int (ffi.is java/lang/Object)) runtime.i64_low_field (|> value .nat runtime.low jvm_int (ffi.is java/lang/Object)) _ (panic! (exception.error ..unknown_member [(ffi.of_string member) (ffi.is java/lang/Object (ffi.as_long value))])))) ))) (def (::toString js_object) (-> Any org/openjdk/nashorn/api/scripting/JSObject) (<| (ffi.is org/openjdk/nashorn/api/scripting/JSObject) (ffi.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject [] [] (org/openjdk/nashorn/api/scripting/AbstractJSObject [] (isFunction self []) boolean (ffi.as_boolean true)) (org/openjdk/nashorn/api/scripting/AbstractJSObject [] (call self [this java/lang/Object args [java/lang/Object]]) java/lang/Object (|> js_object debug.inspection ffi.as_string (ffi.is java/lang/Object))) ))) (def (::slice js_object value) (-> (-> java/lang/Object org/openjdk/nashorn/api/scripting/JSObject) (Array java/lang/Object) org/openjdk/nashorn/api/scripting/JSObject) (<| (ffi.is org/openjdk/nashorn/api/scripting/JSObject) (ffi.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject [] [] (org/openjdk/nashorn/api/scripting/AbstractJSObject [] (isFunction self []) boolean (ffi.as_boolean true)) (org/openjdk/nashorn/api/scripting/AbstractJSObject [] (call self [this java/lang/Object args [java/lang/Object]]) java/lang/Object (|> (java/util/Arrays::copyOfRange value (|> args (array.item 0) maybe.trusted (as Int) ffi.as_int) (ffi.as_int (.int (array.size value)))) (as java/lang/Object) js_object (ffi.is java/lang/Object))) ))) (def (js_structure value) (-> (Array java/lang/Object) org/openjdk/nashorn/api/scripting/JSObject) (let [js_object (is (-> java/lang/Object org/openjdk/nashorn/api/scripting/JSObject) (function (_ sub_value) (<| (when (ffi.as [java/lang/Object] sub_value) {.#Some sub_value} (|> sub_value (as (Array java/lang/Object)) js_structure) {.#None}) (when (ffi.as java/lang/Long sub_value) {.#Some sub_value} (|> sub_value ffi.of_long js_int) {.#None}) ... else (as org/openjdk/nashorn/api/scripting/JSObject sub_value))))] (<| (ffi.is org/openjdk/nashorn/api/scripting/JSObject) (ffi.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject [StructureValue] [] ... Methods (StructureValue [] (getValue self []) java/lang/Object (as java/lang/Object value)) (org/openjdk/nashorn/api/scripting/AbstractJSObject [] (isArray self []) boolean (ffi.as_boolean true)) (org/openjdk/nashorn/api/scripting/AbstractJSObject [] (getMember self [member java/lang/String]) java/lang/Object (when (ffi.of_string member) (^.or "toJSON" "toString") (|> (::toString value) (ffi.is java/lang/Object)) "length" (|> value array.size jvm_int (ffi.is java/lang/Object)) "slice" (|> (::slice js_object value) (ffi.is java/lang/Object)) runtime.variant_tag_field (|> value (array.item 0) maybe.trusted) runtime.variant_flag_field (when (array.item 1 value) {.#Some set!} set! _ (ffi.null)) runtime.variant_value_field (|> value (array.item 2) maybe.trusted js_object (ffi.is java/lang/Object)) _ (panic! (exception.error ..unknown_member [(as Text member) (as java/lang/Object value)])))) (org/openjdk/nashorn/api/scripting/AbstractJSObject [] (getSlot self [idx int]) java/lang/Object (|> value (array.item (|> idx java/lang/Integer::longValue (as Nat))) maybe.trusted js_object (as java/lang/Object))) )))) (exception.def undefined_has_no_lux_representation) (exception.def (unknown_kind_of_host_object object) (Exception java/lang/Object) (exception.report (list ["Class" (ffi.of_string (java/lang/Object::toString (java/lang/Object::getClass object)))] ["Object" (ffi.of_string (java/lang/Object::toString object))] ["Keys" (when (ffi.as org/openjdk/nashorn/api/scripting/ScriptObjectMirror object) {.#Some object} (|> object (org/openjdk/nashorn/api/scripting/ScriptObjectMirror::getOwnKeys true) (array.list {.#None}) (%.list (|>> ffi.of_string %.text))) {.#None} "???")]))) (def (i32 half i64) (-> Text org/openjdk/nashorn/api/scripting/ScriptObjectMirror (Maybe Int)) (|> i64 (org/openjdk/nashorn/api/scripting/JSObject::getMember [(ffi.as_string half)]) (maybe#each (|>> (ffi.as java/lang/Number))) maybe#conjoint (maybe#each (|>> java/lang/Number::longValue ffi.of_long)))) (def (check_int js_object) (-> org/openjdk/nashorn/api/scripting/ScriptObjectMirror (Maybe Int)) (when [(..i32 runtime.i64_high_field js_object) (..i32 runtime.i64_low_field js_object)] [{.#Some high} {.#Some low}] {.#Some (.int (n.+ (|> high .nat (i64.left_shifted 32)) (if (i.< +0 (.int low)) (|> low .nat (i64.left_shifted 32) (i64.right_shifted 32)) (.nat low))))} _ {.#None})) (def (check_variant lux_object js_object) (-> (-> java/lang/Object (Try Any)) org/openjdk/nashorn/api/scripting/ScriptObjectMirror (Maybe Any)) (when [(org/openjdk/nashorn/api/scripting/JSObject::getMember [(ffi.as_string runtime.variant_tag_field)] js_object) (org/openjdk/nashorn/api/scripting/JSObject::getMember [(ffi.as_string runtime.variant_flag_field)] js_object) (org/openjdk/nashorn/api/scripting/JSObject::getMember [(ffi.as_string runtime.variant_value_field)] js_object)] (^.multi [{.#Some tag} ?flag {.#Some value}] [[(ffi.as java/lang/Number tag) (lux_object value)] [{.#Some tag} {try.#Success value}]]) {.#Some [(java/lang/Number::intValue (as java/lang/Number tag)) (maybe.else (ffi.null) ?flag) value]} _ {.#None})) (def (check_tuple lux_object js_object) (-> (-> java/lang/Object (Try Any)) org/openjdk/nashorn/api/scripting/ScriptObjectMirror (Maybe (Array java/lang/Object))) (if (ffi.of_boolean (org/openjdk/nashorn/api/scripting/JSObject::isArray js_object)) (let [num_keys (.nat (ffi.of_int (org/openjdk/nashorn/api/scripting/ScriptObjectMirror::size js_object)))] (loop (again [idx 0 output (is (Array java/lang/Object) (array.empty num_keys))]) (if (n.< num_keys idx) (when (org/openjdk/nashorn/api/scripting/JSObject::getMember (ffi.as_string (%.nat idx)) js_object) {.#Some member} (when (ffi.as org/openjdk/nashorn/internal/runtime/Undefined member) {.#Some _} (again (++ idx) output) {.#None} (when (lux_object member) {try.#Success parsed_member} (again (++ idx) (array.has! idx (as java/lang/Object parsed_member) output)) {try.#Failure error} {.#None})) {.#None} (again (++ idx) output)) {.#Some output}))) {.#None})) (def (lux_object js_object) (-> java/lang/Object (Try Any)) (`` (<| (if (ffi.null? js_object) (exception.except ..null_has_no_lux_representation [{.#None}])) (when (ffi.as org/openjdk/nashorn/internal/runtime/Undefined js_object) {.#Some _} (exception.except ..undefined_has_no_lux_representation []) {.#None}) (,, (with_template [] [(when (ffi.as js_object) {.#Some js_object} {try.#Success js_object} {.#None})] [java/lang/Boolean] [java/lang/String])) (,, (with_template [ ] [(when (ffi.as js_object) {.#Some js_object} {try.#Success ( js_object)} {.#None})] [java/lang/Number java/lang/Number::doubleValue] [StructureValue StructureValue::getValue] [IntValue IntValue::getValue])) (when (ffi.as org/openjdk/nashorn/api/scripting/ScriptObjectMirror js_object) {.#Some js_object} (when (check_int js_object) {.#Some value} {try.#Success value} {.#None} (when (check_variant lux_object js_object) {.#Some value} {try.#Success value} {.#None} (when (check_tuple lux_object js_object) {.#Some value} {try.#Success value} {.#None} (if (ffi.of_boolean (org/openjdk/nashorn/api/scripting/JSObject::isFunction js_object)) {try.#Success js_object} ... (exception.except ..unknown_kind_of_host_object [(as java/lang/Object js_object)]) {try.#Success js_object} )))) {.#None}) ... else ... (exception.except ..unknown_kind_of_host_object [(as java/lang/Object js_object)]) {try.#Success js_object} ))) (def (ensure_function function) (-> Any (Maybe org/openjdk/nashorn/api/scripting/JSObject)) (do maybe.monad [function (|> function (as java/lang/Object) (ffi.as org/openjdk/nashorn/api/scripting/JSObject))] (if (ffi.of_boolean (org/openjdk/nashorn/api/scripting/JSObject::isFunction function)) {.#Some function} {.#None}))) ) @.js (these)) (for @.jvm (these (def (call_macro inputs lux macro) (-> (List Code) Lux org/openjdk/nashorn/api/scripting/JSObject (Try (Try [Lux (List Code)]))) (let [to_js (is (-> Any java/lang/Object) (|>> (as (Array java/lang/Object)) js_structure (as java/lang/Object)))] (<| (as (Try (Try [Lux (List Code)]))) (org/openjdk/nashorn/api/scripting/JSObject::call {.#None} (|> (array.empty 2) (is (Array java/lang/Object)) (array.has! 0 (to_js inputs)) (array.has! 1 (to_js lux))) macro)))) (exception.def (cannot_apply_a_non_function object) (Exception java/lang/Object) (exception.report (list ["Object" (ffi.of_string (java/lang/Object::toString object))]))) (def (expander macro inputs lux) Expander (when (..ensure_function macro) {.#Some macro} (when (call_macro inputs lux macro) {try.#Success output} (|> output (as java/lang/Object) lux_object (as (Try (Try [Lux (List Code)])))) {try.#Failure error} {try.#Failure error}) {.#None} (exception.except ..cannot_apply_a_non_function (as java/lang/Object macro)))) ) @.js (def (expander macro inputs lux) Expander {try.#Success ((as Macro' macro) inputs lux)}) ) (for @.jvm (these (def (evaluate! interpreter alias input) (-> javax/script/ScriptEngine unit.ID _.Expression (Try Any)) (do try.monad [?output (javax/script/ScriptEngine::eval (ffi.as_string (_.code input)) interpreter)] (when ?output {.#Some output} (..lux_object output) {.#None} (exception.except ..null_has_no_lux_representation [{.#Some input}])))) (def (execute! interpreter input) (-> javax/script/ScriptEngine _.Statement (Try Any)) (do try.monad [?output (javax/script/ScriptEngine::eval (ffi.as_string (_.code input)) interpreter)] (in []))) (def (define! interpreter context custom input) (-> javax/script/ScriptEngine unit.ID (Maybe Text) _.Expression (Try [Text Any _.Statement])) (let [global (maybe.else (reference.artifact context) custom) @global (_.var global)] (do try.monad [.let [definition (_.define @global input)] _ (execute! interpreter definition) value (evaluate! interpreter context @global)] (in [global value definition])))) (def host (IO (Host _.Expression _.Statement)) (io (let [interpreter (javax/script/ScriptEngineFactory::getScriptEngine (org/openjdk/nashorn/api/scripting/NashornScriptEngineFactory::new))] (is (Host _.Expression _.Statement) (implementation (def (evaluate alias [_ input]) (..evaluate! interpreter alias input)) (def execute (..execute! interpreter)) (def (define context custom [_ input]) (..define! interpreter context custom input)) (def (ingest context content) (|> content (at utf8.codec decoded) try.trusted (as _.Statement))) (def (re_learn context custom content) (..execute! interpreter content)) (def (re_load context custom content) (do try.monad [_ (..execute! interpreter content)] (..evaluate! interpreter context (_.var (reference.artifact context)))))))))) ) @.js (these (def (eval code) (-> Text (Try (Maybe Any))) ... Note: I have to call "eval" this way ... in order to avoid a quirk of calling eval in Node ... when the code is running under "use strict";. (try (let [return (.js_apply# (function.identity (.js_constant# "eval")) [code])] (if (.js_object_null?# return) {.#None} {.#Some return})))) (def (evaluate! alias input) (-> unit.ID _.Expression (Try Any)) (do try.monad [?output (..eval (_.code input))] (when ?output {.#Some output} (in output) {.#None} (exception.except ..null_has_no_lux_representation [{.#Some input}])))) (def (execute! input) (-> _.Statement (Try Any)) (do try.monad [?output (..eval (_.code input))] (in []))) (def (define! context custom input) (-> unit.ID (Maybe Text) _.Expression (Try [Text Any _.Statement])) (let [global (maybe.else (reference.artifact context) custom) @global (_.var global)] (do try.monad [.let [definition (_.define @global input)] _ (..execute! definition) value (..evaluate! context @global)] (in [global value definition])))) (def host (IO (Host _.Expression _.Statement)) (io (is (Host _.Expression _.Statement) (implementation (def (evaluate alias [_ input]) (..evaluate! alias input)) (def execute ..execute!) (def (define context custom [_ input]) (..define! context custom input)) (def (ingest context content) (|> content (at utf8.codec decoded) try.trusted (as _.Statement))) (def (re_learn context custom content) (..execute! content)) (def (re_load context custom content) (do try.monad [_ (..execute! content)] (..evaluate! context (_.var (reference.artifact context))))))))) )) (def phase_wrapper phase.Wrapper (for @.jvm ... The implementation for @.jvm is technically incorrect. ... However, the JS compiler runs fast enough on Node to be fully hosted there. ... And running the JS compiler on the JVM (on top of Nashorn) is impractically slow. ... This means that in practice, only the @.js implementation matters. ... And since no cross-language boundary needs to be handled, it's a correct implementation. (|>>) @.js (|>>))) (def platform (IO (Platform [Register Text] _.Expression _.Statement)) (do io.monad [host ..host] (in [platform.#file_system (for @.jvm (file.async file.default) @.jvm (file.async file.default) ... TODO: Handle this in a safer manner. ... This would crash if the compiler was run on a browser. @.js (maybe.trusted file.default)) platform.#host host platform.#phase js.expression platform.#runtime runtime.translate platform.#phase_wrapper ..phase_wrapper platform.#write (|>> _.code (at utf8.codec encoded))]))) (def (lux_program context program) (Program _.Expression _.Statement) (let [@process (_.var "process") on_node_js? (|> @process _.type_of (_.= (_.string "undefined")) _.not (_.and (_.the "argv" @process))) node_js_inputs (|> @process (_.the "argv") (_.do "slice" (list (_.int +2)))) no_inputs (_.array (list))] (_.statement (_.apply_1 (_.apply_1 program (runtime.lux//program_args (_.? on_node_js? node_js_inputs no_inputs))) (_.string ""))))) (for @.jvm (def extender Extender ... TODO: Stop relying on coercions ASAP. (<| (as Extender) (function (@self handler)) (as Handler) (function (@self phase)) (as Phase) (function (@self archive parameters)) (as Operation) (function (@self state)) (as Try) try.trusted (as Try) (do try.monad [handler (try.of_maybe (..ensure_function handler)) .let [to_js (is (-> Any java/lang/Object) (|>> (as (Array java/lang/Object)) js_structure (as java/lang/Object)))] output (org/openjdk/nashorn/api/scripting/JSObject::call {.#None} (|> (array.empty 4) (is (Array java/lang/Object)) (array.has! 0 (as java/lang/Object ..phase_wrapper)) (array.has! 1 (to_js archive)) (array.has! 2 (to_js parameters)) (array.has! 3 (to_js state))) handler)] (lux_object (as java/lang/Object output))))) @.js (def extender Extender (|>> as_expected))) (def (declare_success! _) (-> Any (Async Any)) (async.future (at world/environment.default exit +0))) (def (scope body) (-> _.Statement _.Statement) (_.statement (_.apply (_.closure (list) body) (list)))) (def (lux_compiler it) (-> Any platform.Custom) (undefined)) (def _ (program [service cli.service] (let [context (context.js (cli.target service))] (exec (do async.monad [platform (async.future ..platform) _ (/.compiler ..lux_compiler context ..expander analysis.bundle (io.io platform) translation.bundle extension.empty ..lux_program (reference.constant js/reference.system) ..extender service [(packager.package _.use_strict _.code _.then ..scope) (format (cli.target service) (at (the platform.#file_system platform) separator) "program" (the context.#artifact_extension context))])] (..declare_success! [])) (io.io [])))))