diff options
Diffstat (limited to '')
7 files changed, 670 insertions, 201 deletions
diff --git a/stdlib/source/lux/host/js.lux b/stdlib/source/lux/host/js.lux index d50fd29a8..ffc45fd7d 100644 --- a/stdlib/source/lux/host/js.lux +++ b/stdlib/source/lux/host/js.lux @@ -69,6 +69,7 @@ (`` (|>> (~~ (do-template [<find> <replace>] [(text.replace-all <find> <replace>)] + ["\" "\\"] [text.tab "\t"] [text.vertical-tab "\v"] [text.null "\0"] @@ -76,15 +77,15 @@ [text.form-feed "\f"] [text.new-line "\n"] [text.carriage-return "\r"] - ["'" "\'"] [text.double-quote (format "\" text.double-quote)] - ["\" "\\"] )) ))) (def: #export string (-> Text Computation) - (|>> ..sanitize %t :abstraction)) + (|>> ..sanitize + (text.enclose [text.double-quote text.double-quote]) + :abstraction)) (def: argument-separator ", ") (def: field-separator ": ") @@ -95,9 +96,12 @@ (|>> (list/map ..code) (text.join-with ..argument-separator) ..element - ..argument :abstraction)) + (def: #export var + (-> Text Var) + (|>> :abstraction)) + (def: #export (at index array-or-object) (-> Expression Expression Access) (|> (format (:representation array-or-object) (..element (:representation index))) @@ -108,16 +112,40 @@ (-> Text Expression Access) (:abstraction (format (:representation object) "." field))) - (def: #export (do method inputs object) - (-> Text (List Expression) Expression Computation) - (|> (format (:representation (..the method object)) - (|> inputs - (list/map ..code) - (text.join-with ..argument-separator) - ..argument)) + (def: #export (apply/* function inputs) + (-> Expression (List Expression) Computation) + (|> inputs + (list/map ..code) + (text.join-with ..argument-separator) ..argument + (format (:representation function)) :abstraction)) + (do-template [<apply> <arg>+ <type>+ <function>+] + [(`` (def: #export (<apply> function) + (-> Expression (~~ (template.splice <type>+)) Computation) + (.function (_ (~~ (template.splice <arg>+))) + (..apply/* function (list (~~ (template.splice <arg>+))))))) + + (`` (do-template [<definition> <function>] + [(def: #export <definition> (<apply> (..var <function>)))] + + (~~ (template.splice <function>+))))] + + [apply/1 [_0] [Expression] + [[not-a-number? "isNaN"]]] + + [apply/2 [_0 _1] [Expression Expression] + []] + + [apply/3 [_0 _1 _2] [Expression Expression Expression] + []] + ) + + (def: #export (do method inputs object) + (-> Text (List Expression) Expression Computation) + (apply/* (..the method object) inputs)) + (def: #export object (-> (List [Text Expression]) Computation) (|>> (list/map (.function (_ [key val]) @@ -127,10 +155,6 @@ ..argument :abstraction)) - (def: #export var - (-> Text Var) - (|>> :abstraction)) - (def: #export (, pre post) (-> Expression Expression Computation) (|> (format (:representation pre) ", " (:representation post)) @@ -139,16 +163,21 @@ (def: #export (then pre post) (-> Statement Statement Statement) - (:abstraction (format (text.suffix ..statement-suffix - (:representation pre)) - " " + (:abstraction (format (:representation pre) + text.new-line (:representation post)))) + (def: nest + (-> Text Text) + (text.replace-all text.new-line (format text.new-line text.tab))) + (def: block (-> Statement Text) (|>> :representation - (text.suffix ..statement-suffix) - (text.enclose ["{" "}"]))) + (format text.new-line) + ..nest + (text.enclose ["{" + (format text.new-line "}")]))) (def: #export (function name inputs body) (-> Var (List Var) Statement Computation) @@ -176,36 +205,6 @@ ..argument :abstraction)) - (def: #export (apply/* function inputs) - (-> Expression (List Expression) Computation) - (|> inputs - (list/map ..code) - (text.join-with ..argument-separator) - ..argument - (format (:representation function)) - :abstraction)) - - (do-template [<apply> <arg>+ <type>+ <function>+] - [(`` (def: #export (<apply> function) - (-> Expression (~~ (template.splice <type>+)) Computation) - (.function (_ (~~ (template.splice <arg>+))) - (..apply/* function (list (~~ (template.splice <arg>+))))))) - - (`` (do-template [<definition> <function>] - [(def: #export <definition> (<apply> (..var <function>)))] - - (~~ (template.splice <function>+))))] - - [apply/1 [_0] [Expression] - [[not-a-number? "isNaN"]]] - - [apply/2 [_0 _1] [Expression Expression] - []] - - [apply/3 [_0 _1 _2] [Expression Expression Expression] - []] - ) - (do-template [<name> <op>] [(def: #export (<name> param subject) (-> Expression Expression Computation) @@ -278,35 +277,35 @@ (def: #export statement (-> Expression Statement) - (|>> :transmutation)) + (|>> :representation (text.suffix ..statement-suffix) :abstraction)) (def: #export use-strict Statement - (:abstraction (format text.double-quote "use strict" text.double-quote))) + (:abstraction (format text.double-quote "use strict" text.double-quote ..statement-suffix))) (def: #export (declare name) (-> Var Statement) - (:abstraction (format "var " (:representation name)))) + (:abstraction (format "var " (:representation name) ..statement-suffix))) (def: #export (define name value) (-> Var Expression Statement) - (:abstraction (format "var " (:representation name) " = " (:representation value)))) + (:abstraction (format "var " (:representation name) " = " (:representation value) ..statement-suffix))) (def: #export (set name value) (-> Location Expression Statement) - (:abstraction (format (:representation name) " = " (:representation value)))) + (:abstraction (format (:representation name) " = " (:representation value) ..statement-suffix))) (def: #export (throw message) (-> Expression Statement) - (:abstraction (format "throw new Error(" (:representation message) ")"))) + (:abstraction (format "throw " (:representation message) ..statement-suffix))) (def: #export (return value) (-> Expression Statement) - (:abstraction (format "return " (:representation value)))) + (:abstraction (format "return " (:representation value) ..statement-suffix))) (def: #export (delete value) (-> Location Statement) - (:abstraction (format "delete " (:representation value)))) + (:abstraction (format "delete " (:representation value) ..statement-suffix))) (def: #export (if test then! else!) (-> Expression Statement Statement Statement) @@ -330,19 +329,19 @@ (:abstraction (format "try " (..block body) " catch(" (:representation exception) ") " - (..block body)))) + (..block catch)))) (def: #export (for var init condition update iteration) - (-> Var Expression Expression Statement Statement Statement) + (-> Var Expression Expression Expression Statement Statement) (:abstraction (format "for(" (:representation (..define var init)) - ..statement-suffix " " (:representation condition) + " " (:representation condition) ..statement-suffix " " (:representation update) ")" (..block iteration)))) (do-template [<name> <js>] [(def: #export <name> - (-> Location Statement) + (-> Location Expression) (|>> :representation (text.suffix <js>) :abstraction))] diff --git a/stdlib/source/lux/tool/compiler/default/syntax.lux b/stdlib/source/lux/tool/compiler/default/syntax.lux index 19cfea706..528fa6854 100644 --- a/stdlib/source/lux/tool/compiler/default/syntax.lux +++ b/stdlib/source/lux/tool/compiler/default/syntax.lux @@ -267,23 +267,21 @@ (or (!digit? char) ("lux i64 =" (.char (~~ (static ..digit-separator))) char)))) -(`` (template: (!strict-name-char? char) - (not (or ("lux i64 =" (.char (~~ (static ..space))) char) - ("lux i64 =" (.char (~~ (static text.new-line))) char) - - ("lux i64 =" (.char (~~ (static ..name-separator))) char) - - ("lux i64 =" (.char (~~ (static ..open-form))) char) - ("lux i64 =" (.char (~~ (static ..close-form))) char) - - ("lux i64 =" (.char (~~ (static ..open-tuple))) char) - ("lux i64 =" (.char (~~ (static ..close-tuple))) char) - - ("lux i64 =" (.char (~~ (static ..open-record))) char) - ("lux i64 =" (.char (~~ (static ..close-record))) char) - - ("lux i64 =" (.char (~~ (static ..text-delimiter))) char) - ("lux i64 =" (.char (~~ (static ..sigil))) char))))) +(with-expansions [<clauses> (do-template [<char>] + [("lux i64 =" (.char (~~ (static <char>))) char) + #0] + + [..space] [text.new-line] + [..name-separator] + [..open-form] [..close-form] + [..open-tuple] [..close-tuple] + [..open-record] [..close-record] + [..text-delimiter] + [..sigil])] + (`` (template: (!strict-name-char? char) + (cond <clauses> + ## else + #1)))) (template: (!name-char?|head char) (and (!strict-name-char? char) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js.lux b/stdlib/source/lux/tool/compiler/phase/translation/js.lux new file mode 100644 index 000000000..8572c532f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/js.lux @@ -0,0 +1,467 @@ +(.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))))))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux index d989cb223..25522f112 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux @@ -75,7 +75,7 @@ (def: peek-cursor Expression - (.let [idx (|> @cursor (_.the "length") (_.- (_.i32 -1)))] + (.let [idx (|> @cursor (_.the "length") (_.- (_.i32 +1)))] (|> @cursor (_.at idx)))) (def: save-cursor! diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux index 85bdb64ba..98ef827a8 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux @@ -69,13 +69,13 @@ ## [Procedures] ## [[Bits]] (do-template [<name> <op>] - [(def: (<name> [subjectJS paramJS]) + [(def: (<name> [paramJS subjectJS]) Binary (<op> subjectJS (///runtime.i64//to-number paramJS)))] - [bit//left-shift ///runtime.i64//left-shift] - [bit//arithmetic-right-shift ///runtime.i64//arithmetic-right-shift] - [bit//logical-right-shift ///runtime.i64//logic-right-shift] + [i64//left-shift ///runtime.i64//left-shift] + [i64//arithmetic-right-shift ///runtime.i64//arithmetic-right-shift] + [i64//logical-right-shift ///runtime.i64//logic-right-shift] ) ## [[Numbers]] @@ -154,30 +154,30 @@ (bundle.install "is" (binary (product.uncurry _.=))) (bundle.install "try" (unary ///runtime.lux//try)))) -(def: bit-procs +(def: i64-procs Bundle - (<| (bundle.prefix "bit") + (<| (bundle.prefix "i64") (|> bundle.empty (bundle.install "and" (binary (product.uncurry ///runtime.i64//and))) (bundle.install "or" (binary (product.uncurry ///runtime.i64//or))) (bundle.install "xor" (binary (product.uncurry ///runtime.i64//xor))) - (bundle.install "left-shift" (binary bit//left-shift)) - (bundle.install "logical-right-shift" (binary bit//logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) + (bundle.install "left-shift" (binary i64//left-shift)) + (bundle.install "logical-right-shift" (binary i64//logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) + (bundle.install "=" (binary (product.uncurry ///runtime.i64//=))) + (bundle.install "+" (binary (product.uncurry ///runtime.i64//+))) + (bundle.install "-" (binary (product.uncurry ///runtime.i64//-))) ))) (def: int-procs Bundle (<| (bundle.prefix "int") (|> bundle.empty - (bundle.install "+" (binary (product.uncurry ///runtime.i64//+))) - (bundle.install "-" (binary (product.uncurry ///runtime.i64//-))) + (bundle.install "<" (binary (product.uncurry ///runtime.i64//<))) (bundle.install "*" (binary (product.uncurry ///runtime.i64//*))) (bundle.install "/" (binary (product.uncurry ///runtime.i64///))) (bundle.install "%" (binary (product.uncurry ///runtime.i64//%))) - (bundle.install "=" (binary (product.uncurry ///runtime.i64//=))) - (bundle.install "<" (binary (product.uncurry ///runtime.i64//<))) - (bundle.install "to-frac" (unary ///runtime.i64//to-number)) + (bundle.install "frac" (unary ///runtime.i64//to-number)) (bundle.install "char" (unary int//char))))) (def: frac-procs @@ -194,7 +194,7 @@ (bundle.install "smallest" (nullary frac//smallest)) (bundle.install "min" (nullary frac//min)) (bundle.install "max" (nullary frac//max)) - (bundle.install "to-int" (unary ///runtime.i64//from-number)) + (bundle.install "int" (unary ///runtime.i64//from-number)) (bundle.install "encode" (unary (_.do "toString" (list)))) (bundle.install "decode" (unary frac//decode))))) @@ -206,7 +206,7 @@ (bundle.install "<" (binary (product.uncurry _.<))) (bundle.install "concat" (binary text//concat)) (bundle.install "index" (trinary text//index)) - (bundle.install "size" (unary (_.the "length"))) + (bundle.install "size" (unary (|>> (_.the "length") ///runtime.i64//from-number))) (bundle.install "char" (binary (product.uncurry ///runtime.text//char))) (bundle.install "clip" (trinary text//clip)) ))) @@ -224,7 +224,7 @@ Bundle (<| (bundle.prefix "lux") (|> lux-procs - (dictionary.merge bit-procs) + (dictionary.merge i64-procs) (dictionary.merge int-procs) (dictionary.merge frac-procs) (dictionary.merge text-procs) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux index ff72b1ac6..139fcb191 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux @@ -4,7 +4,6 @@ [pipe (#+ cond> new>)]] [data [number - ["." i64] ["." frac]]] [host ["_" js (#+ Computation)]]] @@ -15,19 +14,10 @@ (-> Bit Computation) _.boolean) -(def: high - (-> (I64 Any) (I64 Any)) - (i64.logic-right-shift 32)) - -(def: low - (-> (I64 Any) (I64 Any)) - (let [mask (dec (i64.left-shift 32 1))] - (|>> (i64.and mask)))) - (def: #export (i64 value) (-> (I64 Any) Computation) - (//runtime.i64//new (|> value ..high .int _.i32) - (|> value ..low .int _.i32))) + (//runtime.i64//new (|> value //runtime.high .int _.i32) + (|> value //runtime.low .int _.i32))) (def: #export f64 (-> Frac Computation) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux index 5a37cb8ef..4e95e06b3 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux @@ -5,7 +5,8 @@ [monad (#+ do)] ["p" parser]] [data - [number (#+ hex)] + [number (#+ hex) + ["." i64]] ["." text format] [collection @@ -37,6 +38,15 @@ (def: prefix Text "LuxRuntime") +(def: #export high + (-> (I64 Any) (I64 Any)) + (i64.logic-right-shift 32)) + +(def: #export low + (-> (I64 Any) (I64 Any)) + (let [mask (dec (i64.left-shift 32 1))] + (|>> (i64.and mask)))) + (def: #export variant-tag-field "_lux_tag") (def: #export variant-flag-field "_lux_flag") (def: #export variant-value-field "_lux_value") @@ -138,7 +148,17 @@ (_.try (_.return (_.apply/1 op ..unit)) [ex (_.return (|> ex (_.do "toString" (list))))]))) -(def: length (_.the "length")) +(def: length + (-> Expression Computation) + (_.the "length")) + +(def: last-index + (-> Expression Computation) + (|>> ..length (_.- (_.i32 +1)))) + +(def: (last-element tuple) + (_.at (..last-index tuple) + tuple)) (runtime: (lux//program-args) (with-vars [process output idx] @@ -147,7 +167,7 @@ ($_ _.then (_.define output ..none) (_.for idx - (|> process (_.the "argv") ..length (_.- (_.i32 +1))) + (|> process (_.the "argv") ..last-index) (_.>= (_.i32 +0) idx) (_.-- idx) (_.set output (..some (_.array (list (|> process (_.the "argv") (_.at idx)) @@ -166,13 +186,12 @@ (with-vars [index-min-length] ($_ _.then (_.define index-min-length (_.+ (_.i32 +1) index)) - (_.if (_.> index-min-length - (..length product)) + (_.if (_.< (..length product) + index-min-length) ## No need for recursion. (_.return (_.at index product)) ## Needs recursion. - (_.return (product//left (_.at (|> product ..length (_.- (_.i32 +1))) - product) + (_.return (product//left (last-element product) (_.- (..length product) index-min-length))) )))) @@ -188,14 +207,13 @@ [(_.< index-min-length (..length product)) ## Needs recursion. - (_.return (product//right (_.at (|> product ..length (_.- (_.i32 +1))) - product) + (_.return (product//right (last-element product) (_.- (..length product) index-min-length)))]) ## Must slice (_.return (_.do "slice" (list index) product)))))) -(runtime: (sum//get sum wanted-tag wants-last) +(runtime: (sum//get sum wants-last wanted-tag) (let [no-match! (_.return _.null) sum-tag (|> sum (_.the ..variant-tag-field)) sum-flag (|> sum (_.the ..variant-flag-field)) @@ -272,7 +290,7 @@ (_.= (_.the ..i64-low-field left) (_.the ..i64-low-field right))))) -(runtime: (i64//+ left right) +(runtime: (i64//+ subject parameter) (let [up-16 (_.left-shift (_.i32 +16)) high-16 (_.logic-right-shift (_.i32 +16)) low-16 (_.bit-and (_.i32 (hex "+FFFF"))) @@ -284,15 +302,15 @@ r48 r32 r16 r00 x48 x32 x16 x00] ($_ _.then - (_.define l48 (hh left)) - (_.define l32 (hl left)) - (_.define l16 (lh left)) - (_.define l00 (ll left)) + (_.define l48 (hh subject)) + (_.define l32 (hl subject)) + (_.define l16 (lh subject)) + (_.define l00 (ll subject)) - (_.define r48 (hh right)) - (_.define r32 (hl right)) - (_.define r16 (lh right)) - (_.define r00 (ll right)) + (_.define r48 (hh parameter)) + (_.define r32 (hl parameter)) + (_.define r16 (lh parameter)) + (_.define r00 (ll parameter)) (_.define x00 (_.+ l00 r00)) (_.define x16 (high-16 x00)) @@ -309,11 +327,11 @@ )))) (do-template [<name> <op>] - [(runtime: (<name> left right) - (_.return (i64//new (<op> (_.the ..i64-high-field left) - (_.the ..i64-high-field right)) - (<op> (_.the ..i64-low-field left) - (_.the ..i64-low-field right)))))] + [(runtime: (<name> subject parameter) + (_.return (i64//new (<op> (_.the ..i64-high-field subject) + (_.the ..i64-high-field parameter)) + (<op> (_.the ..i64-low-field subject) + (_.the ..i64-low-field parameter)))))] [i64//xor _.bit-xor] [i64//or _.bit-or] @@ -410,20 +428,20 @@ @i64//logic-right-shift )) -(runtime: (i64//- left right) - (_.return (i64//+ left (i64//negate right)))) +(runtime: (i64//- subject parameter) + (_.return (i64//+ subject (i64//negate parameter)))) -(runtime: (i64//* left right) +(runtime: (i64//* subject parameter) (let [negative? (|>> (_.the ..i64-high-field) (_.< (_.i32 +0)))] - (_.cond (list [(negative? left) - (_.if (negative? right) + (_.cond (list [(negative? subject) + (_.if (negative? parameter) ## Both are negative - (_.return (i64//* (i64//negate left) (i64//negate right))) - ## Left is negative - (_.return (i64//negate (i64//* (i64//negate left) right))))] - [(negative? right) - ## Right is negative - (_.return (i64//negate (i64//* left (i64//negate right))))]) + (_.return (i64//* (i64//negate subject) (i64//negate parameter))) + ## Subject is negative + (_.return (i64//negate (i64//* (i64//negate subject) parameter))))] + [(negative? parameter) + ## Parameter is negative + (_.return (i64//negate (i64//* subject (i64//negate parameter))))]) ## Both are positive (let [up-16 (_.left-shift (_.i32 +16)) high-16 (_.logic-right-shift (_.i32 +16)) @@ -436,15 +454,15 @@ r48 r32 r16 r00 x48 x32 x16 x00] ($_ _.then - (_.define l48 (hh left)) - (_.define l32 (hl left)) - (_.define l16 (lh left)) - (_.define l00 (ll left)) + (_.define l48 (hh subject)) + (_.define l32 (hl subject)) + (_.define l16 (lh subject)) + (_.define l00 (ll subject)) - (_.define r48 (hh right)) - (_.define r32 (hl right)) - (_.define r16 (lh right)) - (_.define r00 (ll right)) + (_.define r48 (hh parameter)) + (_.define r32 (hl parameter)) + (_.define r16 (lh parameter)) + (_.define r00 (ll parameter)) (_.define x00 (_.* l00 r00)) (_.define x16 (high-16 x00)) @@ -473,17 +491,17 @@ (_.bit-or (up-16 x16) x00))) )))))) -(runtime: (i64//< left right) +(runtime: (i64//< subject parameter) (let [negative? (|>> (_.the ..i64-high-field) (_.< (_.i32 +0)))] - (with-vars [-left? -right?] + (with-vars [-subject? -parameter?] ($_ _.then - (_.define -left? (negative? left)) - (_.define -right? (negative? right)) - (_.cond (list [(_.and -left? (_.not right)) + (_.define -subject? (negative? subject)) + (_.define -parameter? (negative? parameter)) + (_.cond (list [(_.and -subject? (_.not -parameter?)) (_.return _.true)] - [(_.and (_.not -left?) right) + [(_.and (_.not -subject?) -parameter?) (_.return _.false)]) - (_.return (negative? (i64//- left right)))))))) + (_.return (negative? (i64//- subject parameter)))))))) (def: (i64//<= subject param) (-> Expression Expression Expression) @@ -507,21 +525,21 @@ [(i64//= i64//min parameter) (_.return i64//one)]) (with-vars [approximation] - ($_ _.then - (_.define approximation (i64//left-shift (i64/// (i64//arithmetic-right-shift subject (_.i32 +1)) - parameter) - (_.i32 +1))) - (_.if (i64//= i64//zero approximation) - (_.return (_.? (negative? parameter) - i64//one - i64//-one)) - (let [remainder (i64//- subject - (i64//* parameter - approximation)) - result (i64//+ approximation - (i64/// remainder - parameter))] - (_.return result))))))] + (let [subject/2 (i64//arithmetic-right-shift subject (_.i32 +1))] + ($_ _.then + (_.define approximation (i64//left-shift (i64/// subject/2 + parameter) + (_.i32 +1))) + (_.if (i64//= i64//zero approximation) + (_.return (_.? (negative? parameter) + i64//one + i64//-one)) + (let [remainder (i64//- subject + (i64//* parameter + approximation))] + (_.return (i64//+ approximation + (i64/// remainder + parameter)))))))))] [(i64//= i64//min parameter) (_.return i64//zero)] @@ -538,15 +556,15 @@ ($_ _.then (_.define result i64//zero) (_.define remainder subject) - (_.while (i64//<= remainder parameter) + (_.while (i64//<= parameter remainder) (with-vars [approximate approximate-result approximate-remainder log2 delta] - (let [rough-estimate (|> (i64//to-number remainder) - (_./ (i64//to-number parameter)) - (_.apply/1 (_.var "Math.floor"))) - approximate-result' (i64//from-number approximate) + (let [approximate-result' (i64//from-number approximate) approx-remainder (i64//* approximate-result parameter)] ($_ _.then - (_.define approximate (_.apply/2 (_.var "Math.max") (_.i32 +1) rough-estimate)) + (_.define approximate (|> (i64//to-number remainder) + (_./ (i64//to-number parameter)) + (_.apply/1 (_.var "Math.floor")) + (_.apply/2 (_.var "Math.max") (_.i32 +1)))) (_.define log2 (|> approximate (_.apply/1 (_.var "Math.log")) (_./ (_.var "Math.LN2")) @@ -614,12 +632,8 @@ (_.return (..some (i64//from-number idx))))))) (runtime: (text//clip text start end) - (let [out-of-bounds? (|>> (_.the ..i64-low-field) (_.> (..length text)))] - (_.if (_.or (out-of-bounds? start) - (out-of-bounds? end)) - (_.return ..none) - (_.return (..some (|> text (_.do "substring" (list (_.the ..i64-low-field start) - (_.the ..i64-low-field end))))))))) + (_.return (|> text (_.do "substring" (list (_.the ..i64-low-field start) + (_.the ..i64-low-field end)))))) (runtime: (text//char text idx) (with-vars [result] @@ -638,18 +652,19 @@ )) (runtime: (io//log message) - (with-vars [console print] - (let [end! (_.return ..unit)] - (_.cond (list [(|> console _.type-of (_.= _.undefined) _.not - (_.and (_.the "log" console))) - ($_ _.then - (_.statement (|> console (_.do "log" (list message)))) - end!)] - [(|> print _.type-of (_.= _.undefined) _.not) - ($_ _.then - (_.statement (_.apply/1 print message)) - end!)]) - end!)))) + (let [console (_.var "console") + print (_.var "print") + end! (_.return ..unit)] + (_.cond (list [(|> console _.type-of (_.= (_.string "undefined")) _.not + (_.and (_.the "log" console))) + ($_ _.then + (_.statement (|> console (_.do "log" (list message)))) + end!)] + [(|> print _.type-of (_.= (_.string "undefined")) _.not) + ($_ _.then + (_.statement (_.apply/1 print (_.apply/1 (_.var "JSON.stringify") message))) + end!)]) + end!))) (runtime: (io//error message) (_.throw message)) @@ -689,7 +704,7 @@ (runtime: (array//read idx array) (let [fail! (_.return ..none)] - (_.if (_.< (_.the "length" array) idx) + (_.if (_.< (..length array) idx) (with-vars [temp] ($_ _.then (_.define temp (_.at idx array)) @@ -699,14 +714,14 @@ fail!))) (runtime: (array//write idx value array) - (_.if (_.< (_.the "length" array) idx) + (_.if (_.< (..length array) idx) ($_ _.then (_.set (_.at idx array) value) (_.return (..some array))) (_.return ..none))) (runtime: (array//delete idx array) - (_.if (_.< (_.the "length" array) idx) + (_.if (_.< (..length array) idx) ($_ _.then (_.delete (_.at idx array)) (_.return (..some array))) |