diff options
Diffstat (limited to '')
-rw-r--r-- | new-luxc/source/luxc/lang/translation/js.lux | 344 |
1 files changed, 0 insertions, 344 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))))) |