diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/translation/js.lux | 467 |
1 files changed, 0 insertions, 467 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js.lux b/stdlib/source/lux/tool/compiler/phase/translation/js.lux deleted file mode 100644 index 8572c532f..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js.lux +++ /dev/null @@ -1,467 +0,0 @@ -(.module: - [lux #* - [io (#+ IO io)] - [control - [monad (#+ do)] - ["." exception (#+ exception:)] - [concurrency - ["." atom (#+ Atom atom)]]] - [data - ["." maybe] - ["." error (#+ Error)] - [number - ["." i64]] - ["." text ("#/." hash) - format] - [collection - ["." array (#+ Array)] - ["." list ("#/." functor)]]] - [macro - ["." template]] - ["." host (#+ import: interface: do-to object) - ["_" js]] - [tool - [compiler - ["." name] - [phase - [macro (#+ Expander)] - ["." translation]]]]] - [/ - ["/." runtime]]) - -(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 [<name>] - [(interface: <name> - (getValue [] java/lang/Object)) - - (`` (import: (~~ (template.identifier ["lux/tool/compiler/phase/translation/js/" <name>])) - (getValue [] java/lang/Object)))] - - [IntValue] - [StructureValue] - ) - -(exception: #export (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 [lux/tool/compiler/phase/translation/js/IntValue] - [] - ## Methods - (lux/tool/compiler/phase/translation/js/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 - ## "<<IntValue>>") - (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: #export (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 [lux/tool/compiler/phase/translation/js/StructureValue] - [] - ## Methods - (lux/tool/compiler/phase/translation/js/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 - ## "<<StructureValue>>") - (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: #export null-has-no-lux-representation) -(exception: #export undefined-has-no-lux-representation) - -(exception: #export (unknown-kind-of-js-object {object java/lang/Object}) - (exception.report - ["Object" (java/lang/Object::toString object)])) - -(exception: #export (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 [<class>] - [(case (host.check <class> js-object) - (#.Some js-object) - (exception.return js-object) - #.None)] - - [java/lang/Boolean] [java/lang/String])) - (~~ (do-template [<class> <method>] - [(case (host.check <class> js-object) - (#.Some js-object) - (exception.return (<method> 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: #export (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: #export Host - (translation.Host _.Expression _.Statement)) - -(def: #export 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))))))) |