- WIP: Infrastructure to interact with Nashorn interpreter.

2 files changed, 382 insertions, 2 deletions

diff --git a/new-luxc/source/luxc/lang/translation/js.lux b/new-luxc/source/luxc/lang/translation/js.lux
index 6cc19e01d..e0278ceeb 100644
--- a/new-luxc/source/luxc/lang/translation/js.lux
+++ b/new-luxc/source/luxc/lang/translation/js.lux
@@ -1,8 +1,388 @@
 (.module:
-  lux)
+  lux
+  (lux (control ["ex" exception #+ exception:]
+                pipe)
+       (data [bit]
+             [maybe]
+             ["e" error #+ Error]
+             [text "text/" Eq<Text>]
+             text/format
+             (coll [array]))
+       [macro]
+       [io #+ Process]
+       [host #+ class: object]
+       (world [file #+ File]))
+  (luxc [lang]
+        [".C" io]))
 
 (type: #export JS Text)
 
 (type: #export Expression JS)
 
 (type: #export Statement JS)
+
+(host.import java/lang/Object
+  (toString [] String))
+
+(host.import java/lang/String
+  (getBytes [String] #try (Array byte)))
+
+(host.import java/lang/Number
+  (doubleValue [] double))
+
+(host.import java/lang/Integer
+  (longValue [] Long))
+
+(host.import java/lang/Long
+  (intValue [] Integer))
+
+(host.import java/lang/AbstractStringBuilder
+  (append [String] AbstractStringBuilder))
+
+(host.import java/lang/StringBuilder
+  (new [])
+  (toString [] String))
+
+(host.import javax/script/ScriptEngine
+  (eval [String] #try #? Object))
+
+(host.import javax/script/ScriptEngineFactory
+  (getScriptEngine [] ScriptEngine))
+
+(host.import jdk/nashorn/api/scripting/NashornScriptEngineFactory
+  (new []))
+
+(host.import jdk/nashorn/api/scripting/NashornScriptEngine)
+
+(host.import jdk/nashorn/api/scripting/JSObject
+  (isArray [] boolean)
+  (isFunction [] boolean)
+  (getMember [String] #? Object)
+  (hasMember [String] boolean))
+
+(host.import jdk/nashorn/api/scripting/AbstractJSObject)
+
+(host.import jdk/nashorn/api/scripting/ScriptObjectMirror)
+
+(host.import jdk/nashorn/internal/runtime/Undefined)
+
+(host.import java/util/Arrays
+  (#static [t] copyOfRange [(Array t) int int] (Array t)))
+
+(type: #export Host
+  {## #artifacts Artifacts
+   ## #context [Text Nat]
+
+   #interpreter ScriptEngine
+   #module-buffer (Maybe StringBuilder)
+   #program-buffer StringBuilder
+   })
+
+(def: #export (init _)
+  (-> Top Host)
+  {#interpreter (ScriptEngineFactory::getScriptEngine [] (NashornScriptEngineFactory::new []))
+   #module-buffer #.None
+   #program-buffer (StringBuilder::new [])})
+
+(def: #export module-js-name Text "module.js")
+
+(def: #export (init-module-buffer _)
+  (-> Top (Meta Unit))
+  (function [compiler]
+    (#e.Success [(update@ #.host
+                          (|>> (:! Host)
+                               (set@ #module-buffer (#.Some (StringBuilder::new [])))
+                               (:! Void))
+                          compiler)
+                 []])))
+
+(exception: #export No-Active-Module-Buffer)
+(exception: #export Cannot-Execute)
+(exception: #export Cannot-Evaluate)
+
+(def: #export module-buffer
+  (Meta StringBuilder)
+  (function [compiler]
+    (case (|> compiler (get@ #.host) (:! Host) (get@ #module-buffer))
+      #.None
+      ((lang.fail (No-Active-Module-Buffer "")) compiler)
+      
+      (#.Some module-buffer)
+      (#e.Success [compiler module-buffer]))))
+
+(def: #export program-buffer
+  (Meta StringBuilder)
+  (function [compiler]
+    (#e.Success [compiler (|> compiler (get@ #.host) (:! Host) (get@ #program-buffer))])))
+
+(def: (execute code)
+  (-> Expression (Meta Unit))
+  (function [compiler]
+    (case (|> compiler
+              (get@ #.host)
+              (:! Host)
+              (get@ #interpreter)
+              (ScriptEngine::eval [code]))
+      (#e.Error error)
+      ((lang.fail (Cannot-Execute error)) compiler)
+      
+      (#e.Success _)
+      (#e.Success [compiler []]))))
+
+(def: (::toString js-object)
+  (-> Top JSObject)
+  (object [] AbstractJSObject []
+    []
+    (AbstractJSObject (isFunction) boolean
+                      true)
+    (AbstractJSObject (call [args (Array Object)]) Object
+                      (Object::toString [] (:! Object js-object)))
+    ))
+
+(def: (::slice js-object value)
+  (-> (-> Object JSObject) (Array Object) JSObject)
+  (object [] AbstractJSObject []
+    []
+    (AbstractJSObject (isFunction) boolean
+                      true)
+    (AbstractJSObject (call [args (Array Object)]) Object
+                      (:! Object
+                          (js-object (Arrays::copyOfRange [value
+                                                           (|> args (array.read +0) maybe.assume (:! Int))
+                                                           (nat-to-int (array.size value))]))))
+    ))
+
+(exception: #export Unknown-Member)
+
+(def: int-high-field Text "H")
+(def: int-low-field Text "L")
+
+(def: jvm-int
+  (-> Nat Integer)
+  (|>> (:! Long) (Long::intValue [])))
+
+(def: low-mask
+  Nat
+  (|> +1 (bit.shift-left +32) n/dec))
+
+(def: high (-> Nat Nat) (bit.shift-right +32))
+(def: low (-> Nat Nat) (bit.and low-mask))
+
+(class: #final LuxInt AbstractJSObject []
+  ## Fields
+  (#public value Long)
+  ## Methods
+  (#public [] (new [value Long]) []
+           (exec (:= ::value value)
+             []))
+  (AbstractJSObject [] (getMember [member String]) Object
+                    (cond (text/= int-high-field member)
+                          (|> ::value int-to-nat high jvm-int)
+                          
+                          (text/= int-low-field member)
+                          (|> ::value int-to-nat low jvm-int)
+                          
+                          ## else
+                          (error! (Unknown-Member (format "     member = " member "\n"
+                                                          "object(int) = " (%i ::value) "\n"))))))
+
+(host.import luxc/lang/translation/js/LuxInt
+  (value Long)
+  (new [Long]))
+
+(class: #final LuxArray AbstractJSObject []
+  ## Fields
+  (#public structure (Array Object))
+  ## Methods
+  (#public [] (new [structure (Array Object)]) []
+           (exec (:= ::structure structure)
+             []))
+  (AbstractJSObject [] (isArray) boolean
+                    true)
+  (AbstractJSObject [] (getMember [member String]) Object
+                    (cond (text/= "toString" member)
+                          (:! Object
+                              (::toString ::structure))
+                          
+                          (text/= "length" member)
+                          (jvm-int (array.size ::structure))
+                          
+                          (text/= "slice" member)
+                          (let [js-object (: (-> Object JSObject)
+                                             (|>> (cond> [(host.instance? (Array Object))]
+                                                         [(:! (Array Object)) [] ::new!]
+
+                                                         [(host.instance? Long)]
+                                                         [(:! Long) [] LuxInt::new]
+
+                                                         ## else
+                                                         [(:! JSObject)])))]
+                            (:! Object
+                                (::slice js-object ::structure)))
+                          
+                          ## else
+                          (error! (Unknown-Member (format "           member = " (:! Text member) "\n"
+                                                          "object(structure) = " (Object::toString [] (:! Object ::structure)) "\n")))))
+  (AbstractJSObject [] (getSlot [idx int]) Object
+                    (|> ::structure
+                        (array.read (|> idx (Integer::longValue []) (:! Nat)))
+                        maybe.assume
+                        (cond> [(host.instance? (Array Object))]
+                               [(:! (Array Object)) [] ::new!]
+
+                               [(host.instance? Long)]
+                               [(:! Long) [] LuxInt::new]
+
+                               ## else
+                               [(:! JSObject)])))
+  )
+
+(host.import luxc/lang/translation/js/LuxArray
+  (structure (Array Object))
+  (new [(Array Object)]))
+
+## (def: (wrap-lux-object object)
+##   (-> Top JSObject)
+##   (if (host.instance? JSObject object)
+##     (lux-obj object)
+##     obj))
+
+(def: (int js-object)
+  (-> JSObject (Maybe Int))
+  (case [(JSObject::getMember [int-high-field] js-object)
+         (JSObject::getMember [int-low-field] js-object)]
+    (^multi [(#.Some high) (#.Some low)]
+            (and (host.instance? Number high)
+                 (host.instance? Number low))
+            [[(Number::longValue [] high) (Number::longValue [] low)]
+             [high low]])
+    (#.Some (nat-to-int (n/+ (-> high (:! Int) int-to-nat (bit.shift-left +32))
+                             (-> low (:! Int) int-to-nat))))
+
+    _
+    #.None))
+
+(def: (extend-array by input)
+  (All [a] (-> Nat (Array a) (Array a)))
+  (let [size (array.size input)]
+    (|> (array.new (n/+ by size))
+        (array.copy size +0 input +0))))
+
+(def: (array js-object)
+  (-> ScriptObjectMirror (Maybe (Array Object)))
+  (if (JSObject::isArray [] js-object)
+    (#.Some (loop [num-keys (ScriptObjectMirror::size js-object)
+                   idx +0
+                   output (: (Array Object)
+                             (array.new num-keys))]
+              (if (n/< num-keys idx)
+                (let [idx-key (|> idx nat-to-int %i)]
+                  (case (JSObject::getMember idx-key js-object)
+                    (#.Some member)
+                    (recur num-keys
+                           (n/inc idx)
+                           (array.write idx output member))
+                    
+                    #.None
+                    (recur (n/inc num-keys)
+                           (n/inc idx)
+                           (extend-array +1 output))))
+                output)))
+    #.None))
+
+(exception: #export Unknown-Kind-Of-JS-Object)
+(exception: #export Null-Has-No-Lux-Representation)
+
+(def: (lux-object js-object)
+  (-> Object (Error Top))
+  (cond (host.null? js-object)
+        (ex.throw Null-Has-No-Lux-Representation "")
+        
+        (host.instance? java.lang.Integer js-object)
+        (ex.return (Integer::longValue [] js-object))
+
+        (or (host.instance? java.lang.Boolean js-object)
+            (host.instance? java.lang.String js-object))
+        (ex.return js-object)
+
+        (host.instance? java.lang.Number js-object)
+        (ex.return (Number::doubleValue [] (:! java.lang.Number js-object)))
+
+        (host.instance? LuxArray js-object)
+        (ex.return (LuxArray::structure [] (:! LuxArray js-object)))
+
+        (host.instance? LuxInt js-object)
+        (ex.return (LuxInt::value [] (:! LuxInt js-object)))
+
+        (host.instance? JSObject js-object)
+        (let [js-object (:! JSObject js-object)]
+          (case (int js-object)
+            (#.Some value)
+            (ex.return value)
+
+            #.None
+            (case (array lux-object js-object)
+              (#.Some value)
+              (ex.return value)
+
+              #.None
+              ## (JSObject::isFunction [] js-object)
+              ## js-object
+
+              ## else
+              (ex.throw Unknown-Kind-Of-JS-Object (Object::toString [] (:! Object js-object))))))
+        
+        ## else
+        (ex.throw Unknown-Kind-Of-JS-Object (Object::toString [] (:! Object js-object)))))
+
+(def: #export (eval code)
+  (-> Expression (Meta Top))
+  (function [compiler]
+    (case (|> compiler
+              (:! Host)
+              (get@ #interpreter)
+              (ScriptEngine::eval [code]))
+      (#e.Error error)
+      ((lang.fail (Cannot-Evaluate error)) compiler)
+      
+      (#e.Success output)
+      (#e.Success [compiler (case output
+                              #.None
+                              []
+
+                              (#.Some output)
+                              (js-to-lux output))]))))
+
+(def: #export unit Text "\u0000")
+
+(def: (module-name module)
+  (-> Text Text)
+  (-> module
+      (text.replace-all "/" "$")
+      (text.replace-all "-" "_")))
+
+(def: (definition-name [module name])
+  (-> Ident Text)
+  (format (module-name module) "$" (&host/def-name name)))
+
+(def: #export (save-definition name code)
+  (-> Ident Expression (Meta Unit))
+  (do macro.Monad<Meta>
+    [#let [js-definition (format "var " (definition-name name) " = " code ";\n")]
+     module-buffer module-buffer
+     #let [_ (StringBuilder::append [js-definition] module-buffer)]]
+    (execute js-definition)))
+
+(def: #export (save-module! target)
+  (-> File (Meta (Process Unit)))
+  (do macro.Monad<Meta>
+    [module macro.current-module-name
+     module-buffer module-buffer
+     program-buffer program-buffer
+     #let [_ (StringBuilder::append [(format module-buffer "\n")] program-buffer)]]
+    (wrap (ioC.write target
+                     (format module "/" module-js-name)
+                     (|> module-buffer
+                         (StringBuilder::toString [])
+                         (String::getBytes ["UTF-8"])
+                         e.assume)))))
diff --git a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
index 742185c2e..4c50a7aef 100644
--- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
@@ -7,7 +7,7 @@
 
 (def: prefix Text "LuxRuntime")
 
-(def: #export unit //.Expression (%t "\u0000"))
+(def: #export unit //.Expression (%t //.unit))
 
 (def: (flag value)
   (-> Bool //.JS)