diff options
Diffstat (limited to 'new-luxc/source')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/js.lux | 344 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/js/eval.jvm.lux | 184 |
2 files changed, 0 insertions, 528 deletions
diff --git a/new-luxc/source/luxc/lang/translation/js.lux b/new-luxc/source/luxc/lang/translation/js.lux deleted file mode 100644 index ddad4d389..000000000 --- a/new-luxc/source/luxc/lang/translation/js.lux +++ /dev/null @@ -1,344 +0,0 @@ -(.module: - lux - (lux (control ["ex" exception #+ exception:] - pipe - [monad #+ do]) - (data [bit] - [maybe] - ["e" error #+ Error] - [text "text/" Eq<Text>] - text/format - (coll [array])) - [macro] - [io #+ IO Process io] - [host #+ class: interface: object] - (world [file #+ File])) - (luxc [lang] - (lang [".L" variable #+ Register] - (host [js #+ JS Expression Statement])) - [".C" io])) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [No-Active-Module-Buffer] - [Cannot-Execute] - - [No-Anchor] - - [Unknown-Member] - ) - -(host.import: java/lang/Object - (toString [] String)) - -(host.import: java/lang/String - (getBytes [String] #try (Array byte))) - -(host.import: java/lang/Integer - (longValue [] Long)) - -(host.import: java/lang/Long - (intValue [] Integer)) - -(host.import: java/lang/CharSequence) - -(host.import: java/lang/Appendable - (append [CharSequence] Appendable)) - -(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) - -(host.import: jdk/nashorn/api/scripting/AbstractJSObject) - -(host.import: java/util/Arrays - (#static [t] copyOfRange [(Array t) int int] (Array t))) - -(type: #export Anchor [Text Register]) - -(type: #export Host - {#context [Text Nat] - #anchor (Maybe Anchor) - #interpreter ScriptEngine - #module-buffer (Maybe StringBuilder) - #program-buffer StringBuilder - }) - -(def: #export init - (IO Host) - (io {#context ["" +0] - #anchor #.None - #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 - (Meta Any) - (function (_ compiler) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #module-buffer (#.Some (StringBuilder::new []))) - (:coerce Nothing)) - compiler) - []]))) - -(def: #export (with-sub-context expr) - (All [a] (-> (Meta a) (Meta [Text a]))) - (function (_ compiler) - (let [old (:coerce Host (get@ #.host compiler)) - [old-name old-sub] (get@ #context old) - new-name (format old-name "$" (%i (.int old-sub)))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #context [new-name +0] old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #context [old-name (inc old-sub)]) - (:coerce Nothing)) - compiler') - [new-name output]]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export context - (Meta Text) - (function (_ compiler) - (#e.Success [compiler - (|> (get@ #.host compiler) - (:coerce Host) - (get@ #context) - (let> [name sub] - name))]))) - -(def: #export (with-anchor anchor expr) - (All [a] (-> Anchor (Meta a) (Meta a))) - (function (_ compiler) - (let [old (:coerce Host (get@ #.host compiler))] - (case (expr (set@ #.host - (:coerce Nothing (set@ #anchor (#.Some anchor) old)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #anchor (get@ #anchor old)) - (:coerce Nothing)) - compiler') - output]) - - (#e.Error error) - (#e.Error error))))) - -(def: #export anchor - (Meta Anchor) - (function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce Host) (get@ #anchor)) - (#.Some anchor) - (#e.Success [compiler anchor]) - - #.None - ((lang.throw No-Anchor "") compiler)))) - -(def: #export module-buffer - (Meta StringBuilder) - (function (_ compiler) - (case (|> compiler (get@ #.host) (:coerce Host) (get@ #module-buffer)) - #.None - ((lang.throw 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) (:coerce Host) (get@ #program-buffer))]))) - -(def: (execute code) - (-> Expression (Meta Any)) - (function (_ compiler) - (case (|> compiler - (get@ #.host) - (:coerce Host) - (get@ #interpreter) - (ScriptEngine::eval [code])) - (#e.Error error) - ((lang.throw Cannot-Execute error) compiler) - - (#e.Success _) - (#e.Success [compiler []])))) - -(def: (::toString js-object) - (-> Any JSObject) - (object [] AbstractJSObject [] - [] - (AbstractJSObject (isFunction) boolean - #1) - (AbstractJSObject (call [args (Array Object)]) Object - (Object::toString [] (:coerce Object js-object))) - )) - -(def: (::slice js-object value) - (-> (-> Object JSObject) (Array Object) JSObject) - (object [] AbstractJSObject [] - [] - (AbstractJSObject (isFunction) boolean - #1) - (AbstractJSObject (call [args (Array Object)]) Object - (:coerce Object - (js-object (Arrays::copyOfRange [value - (|> args (array.read +0) maybe.assume (:coerce Int)) - (.int (array.size value))])))) - )) - -(def: #export int-high-field Text "H") -(def: #export int-low-field Text "L") - -(def: #export variant-tag-field "_lux_tag") -(def: #export variant-flag-field "_lux_flag") -(def: #export variant-value-field "_lux_value") - -(def: jvm-int - (-> Nat Integer) - (|>> (:coerce Long) (Long::intValue []))) - -(def: low-mask - Nat - (|> +1 (bit.left-shift +32) dec)) - -(def: #export high (-> Nat Nat) (bit.logical-right-shift +32)) -(def: #export low (-> Nat Nat) (bit.and low-mask)) - -(interface: IntValue - (getValue [] Long)) - -(host.import: luxc/lang/translation/js/IntValue) - -(def: (js-int value) - (-> Int JSObject) - (object [] AbstractJSObject [IntValue] - [] - ## Methods - (IntValue (getValue) Long - (:coerce Long value)) - (AbstractJSObject (getMember [member String]) Object - (cond (text/= int-high-field member) - (|> value .nat high jvm-int) - - (text/= int-low-field member) - (|> value .nat low jvm-int) - - ## else - (error! (ex.construct Unknown-Member - (format " member = " member "\n" - "object(int) = " (%i value) "\n"))))))) - -(interface: StructureValue - (getValue [] (Array Object))) - -(host.import: luxc/lang/translation/js/StructureValue) - -(def: (js-structure value) - (-> (Array Object) JSObject) - (object [] AbstractJSObject [StructureValue] - [] - ## Methods - (StructureValue (getValue) (Array Object) - (:coerce (Array Object) value)) - (AbstractJSObject (isArray) boolean - #1) - (AbstractJSObject (getMember [member String]) Object - (cond (text/= "toString" member) - (:coerce Object - (::toString value)) - - (text/= "length" member) - (jvm-int (array.size value)) - - (text/= "slice" member) - (let [js-object (: (-> Object JSObject) - (|>> (cond> [(host.instance? (Array Object))] - [(:coerce (Array Object)) js-structure] - - [(host.instance? Long)] - [(:coerce Int) js-int] - - ## else - [(:coerce JSObject)])))] - (:coerce Object - (::slice js-object value))) - - ## else - (error! (ex.construct Unknown-Member (format " member = " (:coerce Text member) "\n" - "object(structure) = " (Object::toString [] (:coerce Object value)) "\n"))))) - (AbstractJSObject (getSlot [idx int]) Object - (|> value - (array.read (|> idx (Integer::longValue []) (:coerce Nat))) - maybe.assume - (cond> [(host.instance? (Array Object))] - [(:coerce (Array Object)) js-structure] - - [(host.instance? Long)] - [(:coerce Int) js-int] - - ## else - [(:coerce JSObject)]) - (:coerce Object))) - )) - -(def: #export unit Text "") - -(def: (module-name module) - (-> Text Text) - (|> module - (text.replace-all "/" "$") - (text.replace-all "-" "_"))) - -(def: #export (definition-name [module name]) - (-> Name Text) - (format (module-name module) "$" (lang.normalize-name name))) - -(def: #export (save-js code) - (-> JS (Meta Any)) - (do macro.Monad<Meta> - [module-buffer module-buffer - #let [_ (Appendable::append [(:coerce CharSequence code)] - module-buffer)]] - (execute code))) - -(def: #export (save-definition name code) - (-> Name Expression (Meta Any)) - (save-js (format "var " (definition-name name) " = " code ";\n"))) - -(def: #export (save-module! target) - (-> File (Meta (Process Any))) - (do macro.Monad<Meta> - [module macro.current-module-name - module-buffer module-buffer - program-buffer program-buffer - #let [module-code (StringBuilder::toString [] module-buffer) - _ (Appendable::append [(:coerce CharSequence (format module-code "\n"))] - program-buffer)]] - (wrap (ioC.write target - (format (module-name module) "/" module-js-name) - (|> module-code - (String::getBytes ["UTF-8"]) - e.assume))))) diff --git a/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux deleted file mode 100644 index 89f419cc3..000000000 --- a/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux +++ /dev/null @@ -1,184 +0,0 @@ -(.module: - lux - (lux (control ["ex" exception #+ exception:]) - (data [bit] - [maybe] - ["e" error #+ Error] - text/format - (coll [array])) - [host]) - (luxc [lang] - (lang (host [js #+ JS Expression Statement]))) - [//]) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Unknown-Kind-Of-JS-Object] - [Null-Has-No-Lux-Representation] - - [Cannot-Evaluate] - ) - -(host.import: java/lang/Object - (toString [] String)) - -(host.import: java/lang/Integer - (longValue [] Long)) - -(host.import: java/lang/Number - (doubleValue [] double) - (longValue [] Long) - (intValue [] Integer)) - -(host.import: javax/script/ScriptEngine - (eval [String] #try #? Object)) - -(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 - (size [] int)) - -(host.import: jdk/nashorn/internal/runtime/Undefined) - -(host.import: luxc/lang/translation/js/IntValue - (getValue [] Long)) - -(host.import: luxc/lang/translation/js/StructureValue - (getValue [] (Array Object))) - -(def: (int js-object) - (-> ScriptObjectMirror (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 [] (:coerce Number high)) - (Number::longValue [] (:coerce Number low))] - [high low]]) - (#.Some (.int (n/+ (|> high (:coerce Nat) (bit.left-shift +32)) - (if (i/< 0 (:coerce Int low)) - (|> low (:coerce Nat) (bit.left-shift +32) (bit.logical-right-shift +32)) - (|> low (:coerce Nat)))))) - - _ - #.None)) - -(def: (variant lux-object js-object) - (-> (-> Object (Error Any)) ScriptObjectMirror (Maybe Any)) - (case [(JSObject::getMember [//.variant-tag-field] js-object) - (JSObject::getMember [//.variant-flag-field] js-object) - (JSObject::getMember [//.variant-value-field] js-object)] - (^multi [(#.Some tag) ?flag (#.Some value)] - (host.instance? Number tag) - [[(Number::intValue [] (:coerce Number tag)) - (lux-object value)] - [tag (#.Some value)]]) - (#.Some [tag (maybe.default (host.null) ?flag) value]) - - _ - #.None)) - -(def: (array lux-object js-object) - (-> (-> Object (Error Any)) ScriptObjectMirror (Maybe (Array Object))) - (if (JSObject::isArray [] js-object) - (let [init-num-keys (.nat (ScriptObjectMirror::size [] js-object))] - (loop [num-keys init-num-keys - idx +0 - output (: (Array Object) - (array.new init-num-keys))] - (if (n/< num-keys idx) - (let [idx-key (|> idx .int %i)] - (case (JSObject::getMember idx-key js-object) - (#.Some member) - (case (lux-object member) - (#e.Success parsed-member) - (recur num-keys (inc idx) (array.write idx (:coerce Object parsed-member) output)) - - (#e.Error error) - #.None) - - #.None - (recur num-keys (inc idx) output))) - (#.Some output)))) - #.None)) - -(def: (lux-object js-object) - (-> Object (Error Any)) - (`` (cond (host.null? js-object) - (ex.throw Null-Has-No-Lux-Representation "") - - (host.instance? Integer js-object) - (ex.return (Integer::longValue [] (:coerce Integer js-object))) - - (or (host.instance? java/lang/Boolean js-object) - (host.instance? java/lang/String js-object)) - (ex.return js-object) - - (host.instance? Number js-object) - (ex.return (Number::doubleValue [] (:coerce Number js-object))) - - (~~ (do-template [<interface> <method>] - [(host.instance? <interface> js-object) - (ex.return (<method> [] (:coerce <interface> js-object)))] - - [StructureValue StructureValue::getValue] - [IntValue IntValue::getValue])) - - (host.instance? ScriptObjectMirror js-object) - (let [js-object (:coerce ScriptObjectMirror js-object)] - (case (int js-object) - (#.Some value) - (ex.return value) - - #.None - (case (variant lux-object 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 [] (:coerce Object js-object))))))) - - ## else - (ex.throw Unknown-Kind-Of-JS-Object (Object::toString [] (:coerce Object js-object)))))) - -(def: #export (eval code) - (-> Expression (Meta Any)) - (function (_ compiler) - (case (|> compiler - (get@ #.host) - (:coerce //.Host) - (get@ #//.interpreter) - (ScriptEngine::eval [code])) - (#e.Error error) - ((lang.throw Cannot-Evaluate error) compiler) - - (#e.Success output) - (case output - #.None - (#e.Success [compiler []]) - - (#.Some output) - (case (lux-object output) - (#e.Success parsed-output) - (#e.Success [compiler parsed-output]) - - (#e.Error error) - ((lang.throw Cannot-Evaluate error) compiler)))))) |