From c1160c68a9a9d3f1243a69d585a06bf1808ef32e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 6 Mar 2019 21:03:21 -0400 Subject: Extracted the JavaScript compiler into its own separate project. --- lux-js/source/program.lux | 487 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 487 insertions(+) create mode 100644 lux-js/source/program.lux (limited to 'lux-js/source') diff --git a/lux-js/source/program.lux b/lux-js/source/program.lux new file mode 100644 index 000000000..1bc5f64f4 --- /dev/null +++ b/lux-js/source/program.lux @@ -0,0 +1,487 @@ +(.module: + [lux #* + [cli (#+ program:)] + ["." io (#+ IO io)] + [control + [monad (#+ do)] + ["." exception (#+ exception:)]] + [data + ["." maybe] + ["." error (#+ Error)] + [number + ["." i64]] + ["." text ("#/." hash) + format] + [collection + ["." array (#+ Array)] + ["." list ("#/." functor)]]] + [macro + ["." template]] + [world + ["." file]] + ["." host (#+ import: interface: do-to object) + ["_" js]] + [tool + [compiler + ["." cli] + ["." name] + ["/" program] + [phase + [macro (#+ Expander)] + ["." translation + [js + ["." runtime] + ["." expression] + ["." extension]]]] + [default + ["." platform (#+ Platform)]]]]]) + +(import: #long java/lang/String) + +(import: #long java/lang/Object + (toString [] java/lang/String)) + +(import: #long java/lang/Long + (intValue [] java/lang/Integer)) + +(import: #long java/lang/Integer + (longValue [] long)) + +(import: #long java/lang/Number + (intValue [] java/lang/Integer) + (longValue [] long) + (doubleValue [] double)) + +(import: #long java/util/Arrays + (#static [t] copyOfRange [(Array t) int int] (Array t))) + +(import: #long javax/script/ScriptEngine + (eval [java/lang/String] #try #? java/lang/Object)) + +(import: #long javax/script/ScriptEngineFactory + (getScriptEngine [] javax/script/ScriptEngine)) + +(import: #long jdk/nashorn/api/scripting/NashornScriptEngineFactory + (new [])) + +(import: #long jdk/nashorn/api/scripting/JSObject + (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 (Array java/lang/Object)] #try java/lang/Object)) + +(import: #long jdk/nashorn/api/scripting/AbstractJSObject) + +(import: #long jdk/nashorn/api/scripting/ScriptObjectMirror + (size [] int) + (toString [] java/lang/String)) + +(import: #long jdk/nashorn/internal/runtime/Undefined) + +(do-template [] + [(interface: + (getValue [] java/lang/Object)) + + (`` (import: (~~ (template.identifier ["program/" ])) + (getValue [] java/lang/Object)))] + + [IntValue] + [StructureValue] + ) + +(exception: (unknown-member {member Text} + {object java/lang/Object}) + (exception.report + ["Member" member] + ["Object" (java/lang/Object::toString object)])) + +(def: jvm-int + (-> (I64 Any) java/lang/Integer) + (|>> (:coerce java/lang/Long) java/lang/Long::intValue)) + +(def: (js-int value) + (-> Int jdk/nashorn/api/scripting/JSObject) + (object [] jdk/nashorn/api/scripting/AbstractJSObject [program/IntValue] + [] + ## Methods + (program/IntValue + (getValue) java/lang/Object + (:coerce java/lang/Object value)) + ## (jdk/nashorn/api/scripting/AbstractJSObject + ## (getDefaultValue {hint (java/lang/Class java/lang/Object)}) java/lang/Object + ## "<>") + (jdk/nashorn/api/scripting/AbstractJSObject + (getMember {member java/lang/String}) java/lang/Object + (case member + (^ (static runtime.i64-high-field)) + (|> value .nat runtime.high jvm-int) + + (^ (static runtime.i64-low-field)) + (|> value .nat runtime.low jvm-int) + + _ + (error! (exception.construct unknown-member [member (:coerce java/lang/Object value)])))) + )) + +(def: (inspect object) + (-> java/lang/Object Text) + (<| (case (host.check java/lang/Boolean object) + (#.Some value) + (%b value) + #.None) + (case (host.check java/lang/String object) + (#.Some value) + (%t value) + #.None) + (case (host.check java/lang/Long object) + (#.Some value) + (%i (.int value)) + #.None) + (case (host.check java/lang/Number object) + (#.Some value) + (%f (java/lang/Number::doubleValue value)) + #.None) + (case (host.check (Array java/lang/Object) object) + (#.Some value) + (let [value (:coerce (Array java/lang/Object) value)] + (case (array.read 0 value) + (^multi (#.Some tag) + [(host.check java/lang/Integer tag) + (#.Some tag)] + [[(array.read 1 value) + (array.read 2 value)] + [last? + (#.Some choice)]]) + (let [last? (case last? + (#.Some _) #1 + #.None #0)] + (|> (format (%n (.nat (java/lang/Integer::longValue tag))) + " " (%b last?) + " " (inspect choice)) + (text.enclose ["(" ")"]))) + + _ + (|> value + array.to-list + (list/map inspect) + (text.join-with " ") + (text.enclose ["[" "]"])))) + #.None) + (java/lang/Object::toString object))) + +(def: (::toString js-object) + (-> Any jdk/nashorn/api/scripting/JSObject) + (object [] jdk/nashorn/api/scripting/AbstractJSObject [] + [] + (jdk/nashorn/api/scripting/AbstractJSObject + (isFunction) boolean + #1) + (jdk/nashorn/api/scripting/AbstractJSObject + (call {this java/lang/Object} {args (Array java/lang/Object)}) java/lang/Object + (inspect (:coerce java/lang/Object js-object))) + )) + +(def: (::slice js-object value) + (-> (-> java/lang/Object jdk/nashorn/api/scripting/JSObject) (Array java/lang/Object) jdk/nashorn/api/scripting/JSObject) + (object [] jdk/nashorn/api/scripting/AbstractJSObject [] + [] + (jdk/nashorn/api/scripting/AbstractJSObject + (isFunction) boolean + #1) + (jdk/nashorn/api/scripting/AbstractJSObject + (call {this java/lang/Object} {args (Array java/lang/Object)}) java/lang/Object + (|> (java/util/Arrays::copyOfRange value + (|> args (array.read 0) maybe.assume (:coerce Int)) + (.int (array.size value))) + js-object + (:coerce java/lang/Object))) + )) + +(def: (js-structure value) + (-> (Array java/lang/Object) jdk/nashorn/api/scripting/JSObject) + (let [js-object (: (-> java/lang/Object jdk/nashorn/api/scripting/JSObject) + (function (_ sub-value) + (<| (case (host.check (Array java/lang/Object) sub-value) + (#.Some sub-value) + (|> sub-value (:coerce (Array java/lang/Object)) js-structure) + #.None) + (case (host.check java/lang/Long sub-value) + (#.Some sub-value) + (|> sub-value (:coerce Int) js-int) + #.None) + ## else + (:coerce jdk/nashorn/api/scripting/JSObject sub-value))))] + (object [] jdk/nashorn/api/scripting/AbstractJSObject [program/StructureValue] + [] + ## Methods + (program/StructureValue + (getValue) java/lang/Object + (:coerce (Array java/lang/Object) value)) + ## (jdk/nashorn/api/scripting/AbstractJSObject + ## (getDefaultValue {hint (java/lang/Class java/lang/Object)}) java/lang/Object + ## "<>") + (jdk/nashorn/api/scripting/AbstractJSObject + (isArray) boolean + #1) + (jdk/nashorn/api/scripting/AbstractJSObject + (getMember {member java/lang/String}) java/lang/Object + (case member + "toString" + (:coerce java/lang/Object + (::toString value)) + + "length" + (jvm-int (array.size value)) + + "slice" + (:coerce java/lang/Object + (::slice js-object value)) + + (^ (static runtime.variant-tag-field)) + (|> value (array.read 0) maybe.assume) + + (^ (static runtime.variant-flag-field)) + (case (array.read 1 value) + (#.Some set!) + set! + + _ + (host.null)) + + (^ (static runtime.variant-value-field)) + (|> value (array.read 2) maybe.assume js-object (:coerce java/lang/Object)) + + _ + (error! (exception.construct unknown-member [(:coerce Text member) (:coerce java/lang/Object value)]))) + ) + (jdk/nashorn/api/scripting/AbstractJSObject + (getSlot {idx int}) java/lang/Object + (|> value + (array.read (|> idx java/lang/Integer::longValue (:coerce Nat))) + maybe.assume + js-object + (:coerce java/lang/Object))) + ))) + +(exception: null-has-no-lux-representation) +(exception: undefined-has-no-lux-representation) + +(exception: (unknown-kind-of-js-object {object java/lang/Object}) + (exception.report + ["Object" (java/lang/Object::toString object)])) + +(exception: (cannot-apply-a-non-function {object java/lang/Object}) + (exception.report + ["Object" (java/lang/Object::toString object)])) + +(def: (check-int js-object) + (-> jdk/nashorn/api/scripting/ScriptObjectMirror + (Maybe Int)) + (case [(jdk/nashorn/api/scripting/JSObject::getMember [runtime.i64-high-field] js-object) + (jdk/nashorn/api/scripting/JSObject::getMember [runtime.i64-low-field] js-object)] + (^multi [(#.Some high) (#.Some low)] + [[(host.check java/lang/Number high) + (host.check java/lang/Number low)] + [(#.Some high) (#.Some low)]] + [[(java/lang/Number::longValue high) + (java/lang/Number::longValue low)] + [high low]]) + (#.Some (.int (n/+ (|> high .nat (i64.left-shift 32)) + (if (i/< +0 (.int low)) + (|> low .nat (i64.left-shift 32) (i64.logic-right-shift 32)) + (.nat low))))) + + _ + #.None)) + +(def: (check-variant lux-object js-object) + (-> (-> java/lang/Object (Error Any)) + jdk/nashorn/api/scripting/ScriptObjectMirror + (Maybe Any)) + (case [(jdk/nashorn/api/scripting/JSObject::getMember [runtime.variant-tag-field] js-object) + (jdk/nashorn/api/scripting/JSObject::getMember [runtime.variant-flag-field] js-object) + (jdk/nashorn/api/scripting/JSObject::getMember [runtime.variant-value-field] js-object)] + (^multi [(#.Some tag) ?flag (#.Some value)] + [(host.check java/lang/Number tag) + (#.Some tag)] + [(lux-object value) + (#.Some value)]) + (#.Some [(java/lang/Number::intValue tag) + (maybe.default (host.null) ?flag) + value]) + + _ + #.None)) + +(def: (check-array lux-object js-object) + (-> (-> java/lang/Object (Error Any)) + jdk/nashorn/api/scripting/ScriptObjectMirror + (Maybe (Array java/lang/Object))) + (if (jdk/nashorn/api/scripting/JSObject::isArray js-object) + (let [init-num-keys (.nat (jdk/nashorn/api/scripting/ScriptObjectMirror::size js-object))] + (loop [num-keys init-num-keys + idx 0 + output (: (Array java/lang/Object) + (array.new init-num-keys))] + (if (n/< num-keys idx) + (case (jdk/nashorn/api/scripting/JSObject::getMember (%n idx) js-object) + (#.Some member) + (case (lux-object member) + (#error.Success parsed-member) + (recur num-keys (inc idx) (array.write idx (:coerce java/lang/Object parsed-member) output)) + + (#error.Failure error) + #.None) + + #.None + (recur num-keys (inc idx) output)) + (#.Some output)))) + #.None)) + +(def: (lux-object js-object) + (-> java/lang/Object (Error Any)) + (`` (<| (if (host.null? js-object) + (exception.throw null-has-no-lux-representation [])) + (case (host.check jdk/nashorn/internal/runtime/Undefined js-object) + (#.Some _) + (exception.throw undefined-has-no-lux-representation []) + #.None) + (~~ (do-template [] + [(case (host.check js-object) + (#.Some js-object) + (exception.return js-object) + #.None)] + + [java/lang/Boolean] [java/lang/String])) + (~~ (do-template [ ] + [(case (host.check js-object) + (#.Some js-object) + (exception.return ( js-object)) + #.None)] + + [java/lang/Number java/lang/Number::doubleValue] + [StructureValue StructureValue::getValue] + [IntValue IntValue::getValue])) + (case (host.check jdk/nashorn/api/scripting/ScriptObjectMirror js-object) + (#.Some js-object) + (case (check-int js-object) + (#.Some value) + (exception.return value) + + #.None + (case (check-variant lux-object js-object) + (#.Some value) + (exception.return value) + + #.None + (case (check-array lux-object js-object) + (#.Some value) + (exception.return value) + + #.None + (if (jdk/nashorn/api/scripting/JSObject::isFunction js-object) + (exception.return js-object) + (exception.throw unknown-kind-of-js-object (:coerce java/lang/Object js-object)))))) + #.None) + ## else + (exception.throw unknown-kind-of-js-object (:coerce java/lang/Object js-object)) + ))) + +(def: (ensure-macro macro) + (-> Macro (Maybe jdk/nashorn/api/scripting/JSObject)) + (let [macro (:coerce java/lang/Object macro)] + (do maybe.monad + [macro (host.check jdk/nashorn/api/scripting/JSObject macro)] + (if (jdk/nashorn/api/scripting/JSObject::isFunction macro) + (#.Some macro) + #.None)))) + +(def: (call-macro inputs lux macro) + (-> (List Code) Lux jdk/nashorn/api/scripting/JSObject (Error (Error [Lux (List Code)]))) + (let [to-js (: (-> Any java/lang/Object) + (|>> (:coerce (Array java/lang/Object)) js-structure (:coerce java/lang/Object)))] + (<| (:coerce (Error (Error [Lux (List Code)]))) + (jdk/nashorn/api/scripting/JSObject::call #.None + (|> (array.new 2) + (: (Array java/lang/Object)) + (array.write 0 (to-js inputs)) + (array.write 1 (to-js lux))) + macro)))) + +(def: (expander macro inputs lux) + Expander + (case (ensure-macro macro) + (#.Some macro) + (case (call-macro inputs lux macro) + (#error.Success output) + (|> output + (:coerce java/lang/Object) + lux-object + (:coerce (Error (Error [Lux (List Code)])))) + + (#error.Failure error) + (#error.Failure error)) + + #.None + (exception.throw cannot-apply-a-non-function (:coerce java/lang/Object macro)))) + +(def: separator "$") + +(def: (evaluate! interpreter alias input) + (-> javax/script/ScriptEngine Text _.Expression (Error Any)) + (do error.monad + [?output (javax/script/ScriptEngine::eval (_.code input) interpreter) + output (case ?output + (#.Some output) + (wrap output) + + #.None + (exception.throw null-has-no-lux-representation [])) + lux-output (..lux-object output)] + (wrap lux-output))) + +(def: (execute! interpreter alias input) + (-> javax/script/ScriptEngine Text _.Statement (Error Any)) + (do error.monad + [?output (javax/script/ScriptEngine::eval (_.code input) interpreter)] + (wrap []))) + +(def: (define! interpreter [module name] input) + (-> javax/script/ScriptEngine Name _.Expression (Error [Text Any])) + (let [global (format (text.replace-all .module-separator ..separator module) + ..separator (name.normalize name) + "___" (%n (text/hash name))) + @global (_.var global)] + (do error.monad + [_ (execute! interpreter global (_.define @global input)) + value (evaluate! interpreter global @global)] + (wrap [global value])))) + +(type: Host + (translation.Host _.Expression _.Statement)) + +(def: host + (IO Host) + (io (let [interpreter (javax/script/ScriptEngineFactory::getScriptEngine + (jdk/nashorn/api/scripting/NashornScriptEngineFactory::new))] + (: Host + (structure + (def: (evaluate! alias input) + (..evaluate! interpreter (name.normalize alias) input)) + (def: execute! (..execute! interpreter)) + (def: define! (..define! interpreter))))))) + +(def: platform + (IO (Platform IO _.Var _.Expression _.Statement)) + (do io.monad + [host ..host] + (wrap {#platform.&monad io.monad + #platform.&file-system file.system + #platform.host host + #platform.phase expression.translate + #platform.runtime runtime.translate}))) + +(program: [{service cli.service}] + (/.compiler ..expander ..platform extension.bundle service)) -- cgit v1.2.3