aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/host/python.lux12
-rw-r--r--new-luxc/source/program.lux2
-rw-r--r--stdlib/source/lux/host/js.lux123
-rw-r--r--stdlib/source/lux/tool/compiler/default/syntax.lux32
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js.lux467
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/case.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux34
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux14
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux199
9 files changed, 677 insertions, 208 deletions
diff --git a/new-luxc/source/luxc/lang/host/python.lux b/new-luxc/source/luxc/lang/host/python.lux
index 43c8b28a3..aafa07161 100644
--- a/new-luxc/source/luxc/lang/host/python.lux
+++ b/new-luxc/source/luxc/lang/host/python.lux
@@ -236,8 +236,8 @@
(def: nest
(-> Statement Text)
(|>> :representation
- (format "\n")
- (text.replace-all "\n" "\n ")))
+ (format text.new-line)
+ (text.replace-all text.new-line (format text.new-line text.tab))))
(def: #export (set-nth! idx value array)
(-> Expression Expression Expression Statement)
@@ -255,7 +255,7 @@
(:abstraction
(format "if " (expression test) ":"
(nest then!)
- "\n" "else:"
+ text.new-line "else:"
(nest else!))))
(def: #export (when! test then!)
@@ -275,7 +275,7 @@
(-> Statement Statement Statement)
(:abstraction
(format (:representation pre!)
- "\n"
+ text.new-line
(:representation post!))))
(def: #export (while! test body!)
@@ -297,7 +297,7 @@
(def: #export no-op!
Statement
- (:abstraction "\n"))
+ (:abstraction text.new-line))
(type: #export Except
{#classes (List Text)
@@ -311,7 +311,7 @@
(nest body!)
(|> excepts
(list/map (function (_ [classes exception catch!])
- (format "\n" "except (" (text.join-with "," classes)
+ (format text.new-line "except (" (text.join-with "," classes)
") as " (..name exception) ":"
(nest catch!))))
(text.join-with "")))))
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
index d576e89ae..c669b9c24 100644
--- a/new-luxc/source/program.lux
+++ b/new-luxc/source/program.lux
@@ -56,4 +56,4 @@
(program: [{service cli.service}]
## (/.compiler macro.jvm ..jvm commonJVM.bundle service)
- (/.compiler macro.jvm ..js extensionJS.bundle service))
+ (/.compiler jsT.expander ..js extensionJS.bundle service))
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)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 04:16:31 +0000