diff options
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/js.lux | 317 |
1 files changed, 169 insertions, 148 deletions
diff --git a/new-luxc/source/luxc/lang/translation/js.lux b/new-luxc/source/luxc/lang/translation/js.lux index e0278ceeb..fa056145d 100644 --- a/new-luxc/source/luxc/lang/translation/js.lux +++ b/new-luxc/source/luxc/lang/translation/js.lux @@ -1,7 +1,8 @@ (.module: lux (lux (control ["ex" exception #+ exception:] - pipe) + pipe + [monad #+ do]) (data [bit] [maybe] ["e" error #+ Error] @@ -10,7 +11,7 @@ (coll [array])) [macro] [io #+ Process] - [host #+ class: object] + [host #+ class: interface: object] (world [file #+ File])) (luxc [lang] [".C" io])) @@ -28,7 +29,8 @@ (getBytes [String] #try (Array byte))) (host.import java/lang/Number - (doubleValue [] double)) + (doubleValue [] double) + (longValue [] Long)) (host.import java/lang/Integer (longValue [] Long)) @@ -62,7 +64,8 @@ (host.import jdk/nashorn/api/scripting/AbstractJSObject) -(host.import jdk/nashorn/api/scripting/ScriptObjectMirror) +(host.import jdk/nashorn/api/scripting/ScriptObjectMirror + (size [] int)) (host.import jdk/nashorn/internal/runtime/Undefined) @@ -168,78 +171,83 @@ (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)])))] +(interface: IntValue + (getValue [] Long)) + +(host.import luxc/lang/translation/js/IntValue + (getValue [] Long)) + +(def: (js-int value) + (-> Int JSObject) + (object [] AbstractJSObject [IntValue] + [] + ## Methods + (IntValue (getValue) Long + (:! Long 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"))))))) + +(interface: StructureValue + (getValue [] (Array Object))) + +(host.import luxc/lang/translation/js/StructureValue + (getValue [] (Array Object))) + +(def: (js-structure value) + (-> (Array Object) JSObject) + (object [] AbstractJSObject [StructureValue] + [] + ## Methods + (StructureValue (getValue) (Array Object) + (:! (Array Object) value)) + (AbstractJSObject (isArray) boolean + true) + (AbstractJSObject (getMember [member String]) Object + (cond (text/= "toString" member) (:! 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)])) + (::toString value)) + + (text/= "length" member) + (jvm-int (array.size value)) + + (text/= "slice" member) + (let [js-object (: (-> Object JSObject) + (|>> (cond> [(host.instance? (Array Object))] + [(:! (Array Object)) js-structure] + + [(host.instance? Long)] + [(:! Int) js-int] + + ## else + [(:! JSObject)])))] + (:! Object + (::slice js-object value))) + + ## else + (error! (Unknown-Member (format " member = " (:! Text member) "\n" + "object(structure) = " (Object::toString [] (:! Object value)) "\n"))))) + (AbstractJSObject (getSlot [idx int]) Object + (|> value + (array.read (|> idx (Integer::longValue []) (:! Nat))) + maybe.assume + (cond> [(host.instance? (Array Object))] + [(:! (Array Object)) js-structure] + + [(host.instance? Long)] + [(:! Int) js-int] + + ## else + [(:! JSObject)]) + (:! Object))) + )) ## (def: (wrap-lux-object object) ## (-> Top JSObject) @@ -248,16 +256,17 @@ ## obj)) (def: (int js-object) - (-> JSObject (Maybe Int)) + (-> 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 [] high) (Number::longValue [] low)] + [[(Number::longValue [] (:! Number high)) + (Number::longValue [] (:! Number low))] [high low]]) - (#.Some (nat-to-int (n/+ (-> high (:! Int) int-to-nat (bit.shift-left +32)) - (-> low (:! Int) int-to-nat)))) + (#.Some (nat-to-int (n/+ (|> high (:! Int) int-to-nat (bit.shift-left +32)) + (|> low (:! Int) int-to-nat)))) _ #.None)) @@ -268,26 +277,32 @@ (|> (array.new (n/+ by size)) (array.copy size +0 input +0)))) -(def: (array js-object) - (-> ScriptObjectMirror (Maybe (Array Object))) +(def: (array element-parser js-object) + (-> (-> Object (Error Top)) 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))) + (let [init-num-keys (int-to-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 nat-to-int %i)] + (case (JSObject::getMember idx-key js-object) + (#.Some member) + (case (element-parser member) + (#e.Success parsed-member) + (recur num-keys + (n/inc idx) + (array.write idx (:! Object parsed-member) output)) + + (#e.Error error) + #.None) + + #.None + (recur (n/inc num-keys) + (n/inc idx) + (extend-array +1 output)))) + (#.Some output)))) #.None)) (exception: #export Unknown-Kind-Of-JS-Object) @@ -295,45 +310,46 @@ (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))))) + (`` (cond (host.null? js-object) + (ex.throw Null-Has-No-Lux-Representation "") + + (host.instance? Integer js-object) + (ex.return (Integer::longValue [] (:! 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 [] (:! Number js-object))) + + (~~ (do-template [<interface> <method>] + [(host.instance? <interface> js-object) + (ex.return (<method> [] (:! <interface> js-object)))] + + [StructureValue StructureValue::getValue] + [IntValue IntValue::getValue])) + + (host.instance? ScriptObjectMirror js-object) + (let [js-object (:! ScriptObjectMirror 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)) @@ -346,31 +362,36 @@ ((lang.fail (Cannot-Evaluate error)) compiler) (#e.Success output) - (#e.Success [compiler (case output - #.None - [] + (case output + #.None + (#e.Success [compiler []]) + + (#.Some output) + (case (lux-object output) + (#e.Success parsed-output) + (#e.Success [compiler parsed-output]) - (#.Some output) - (js-to-lux output))])))) + (#e.Error error) + (#e.Error error)))))) (def: #export unit Text "\u0000") (def: (module-name module) (-> Text Text) - (-> module + (|> module (text.replace-all "/" "$") (text.replace-all "-" "_"))) (def: (definition-name [module name]) (-> Ident Text) - (format (module-name module) "$" (&host/def-name name))) + (format (module-name module) "$" (lang.normalize-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)]] + #let [_ (AbstractStringBuilder::append [js-definition] module-buffer)]] (execute js-definition))) (def: #export (save-module! target) @@ -379,10 +400,10 @@ [module macro.current-module-name module-buffer module-buffer program-buffer program-buffer - #let [_ (StringBuilder::append [(format module-buffer "\n")] program-buffer)]] + #let [module-code (StringBuilder::toString [] module-buffer) + _ (AbstractStringBuilder::append [(format module-code "\n")] program-buffer)]] (wrap (ioC.write target (format module "/" module-js-name) - (|> module-buffer - (StringBuilder::toString []) + (|> module-code (String::getBytes ["UTF-8"]) e.assume))))) |