diff options
Diffstat (limited to 'new-luxc/source/luxc')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/js.lux | 382 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux | 2 |
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) |