Extracted the JavaScript compiler into its own separate project.

1 files changed, 487 insertions, 0 deletions

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