diff options
Diffstat (limited to 'stdlib/source')
9 files changed, 441 insertions, 25 deletions
diff --git a/stdlib/source/lux/host/js.lux b/stdlib/source/lux/host/js.lux index b297be69a..e61ce7985 100644 --- a/stdlib/source/lux/host/js.lux +++ b/stdlib/source/lux/host/js.lux @@ -29,16 +29,16 @@ (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+)))))] [Expression Expression' [Code]] - [Location Location' [Expression' Code]] + [Computation Computation' [Expression' Code]] + [Location Location' [Computation' Expression' Code]] ) (do-template [<type> <brand> <super>+] [(abstract: #export <brand> {} Any) (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+)))))] - [Var Var' [Location' Expression' Code]] - [Access Access' [Location' Expression' Code]] - [Computation Computation' [Expression' Code]] + [Var Var' [Location' Computation' Expression' Code]] + [Access Access' [Location' Computation' Expression' Code]] [Statement Statement' [Code]] ) @@ -109,7 +109,7 @@ (:abstraction (format (:representation object) "." field))) (def: #export (do method inputs object) - (-> Text (List Expression) Expression Access) + (-> Text (List Expression) Expression Computation) (|> (format (:representation (..the method object)) (|> inputs (list/map ..code) @@ -131,6 +131,12 @@ (-> Text Var) (|>> :abstraction)) + (def: #export (, pre post) + (-> Expression Expression Computation) + (|> (format (:representation pre) ", " (:representation post)) + ..argument + :abstraction)) + (def: #export (then pre post) (-> Statement Statement Statement) (:abstraction (format (text.suffix ..statement-suffix @@ -260,6 +266,16 @@ ..argument :abstraction)) + (def: #export (new constructor inputs) + (-> Expression (List Expression) Computation) + (|> (format "new " (:representation constructor) + (|> inputs + (list/map ..code) + (text.join-with ..argument-separator) + ..argument)) + ..argument + :abstraction)) + (def: #export statement (-> Expression Statement) (|>> :transmutation)) diff --git a/stdlib/source/lux/tool/compiler/phase/extension.lux b/stdlib/source/lux/tool/compiler/phase/extension.lux index fd54d54b4..86b2e6b38 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension.lux @@ -58,6 +58,9 @@ ["Expected" (%n arity)] ["Actual" (%n args)])) +(exception: #export (incorrect-syntax {name Name}) + (ex.report ["Extension" (%t name)])) + (def: #export (install name handler) (All [s i o] (-> Text (Handler s i o) (Operation s i o Any))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux new file mode 100644 index 000000000..a40b4953f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux @@ -0,0 +1,15 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common] + ["." host]]) + +(def: #export bundle + Bundle + (|> common.bundle + (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux new file mode 100644 index 000000000..3cf3fbc27 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux @@ -0,0 +1,231 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["e" error] + ["." product] + [number (#+ hex)] + [collection + ["." list ("#/." functor)] + ["." dictionary]]] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax:)]] + [host (#+ import:) + ["_" js (#+ Expression Computation)]]] + [/// + ["///." runtime (#+ Operation Phase Handler Bundle)] + ["///." primitive] + ["//." /// + ["." synthesis (#+ Synthesis)] + ["." extension + ["." bundle]]]]) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector 0 Expression) Computation)) +(type: #export Unary (-> (Vector 1 Expression) Computation)) +(type: #export Binary (-> (Vector 2 Expression) Computation)) +(type: #export Trinary (-> (Vector 3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +(syntax: (arity: {name s.local-identifier} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!phase g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + Handler) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do /////.monad + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + +(arity: nullary 0) +(arity: unary 1) +(arity: binary 2) +(arity: trinary 3) + +(def: #export (variadic extension) + (-> Variadic Handler) + (function (_ extension-name) + (function (_ phase inputsS) + (do /////.monad + [inputsI (monad.map @ phase inputsS)] + (wrap (extension inputsI)))))) + +## [Procedures] +## [[Bits]] +(do-template [<name> <op>] + [(def: (<name> [subjectJS paramJS]) + Binary + (<op> subjectJS (///runtime.i64//to-number paramJS)))] + + [bit//left-shift ///runtime.i64//left-shift] + [bit//arithmetic-right-shift ///runtime.i64//arithmetic-right-shift] + [bit//logical-right-shift ///runtime.i64//logic-right-shift] + ) + +## [[Numbers]] +(import: #long java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-template [<name> <const>] + [(def: (<name> _) + Nullary + (///primitive.f64 <const>))] + + [frac//smallest (java/lang/Double::MIN_VALUE)] + [frac//min (f/* -1.0 (java/lang/Double::MAX_VALUE))] + [frac//max (java/lang/Double::MAX_VALUE)] + ) + +(def: frac//decode + Unary + (|>> list + (_.apply/* (_.var "parseFloat")) + _.return + (_.closure (list)) + ///runtime.lux//try)) + +(def: int//char + Unary + (|>> ///runtime.i64//to-number + (list) + (_.apply/* (_.var "String.fromCharCode")))) + +## [[Text]] +(def: (text//concat [subjectJS paramJS]) + Binary + (|> subjectJS (_.do "concat" (list paramJS)))) + +(do-template [<name> <runtime>] + [(def: (<name> [subjectJS paramJS extraJS]) + Trinary + (<runtime> subjectJS paramJS extraJS))] + + [text//clip ///runtime.text//clip] + [text//index ///runtime.text//index] + ) + +## [[IO]] +(def: (io//log messageJS) + Unary + ($_ _., + (///runtime.io//log messageJS) + ///runtime.unit)) + +(def: (io//exit codeJS) + Unary + (let [@@process (_.var "process") + @@window (_.var "window") + @@location (_.var "location")] + ($_ _.or + ($_ _.and + (_.not (_.= _.undefined (_.type-of @@process))) + (_.the "exit" @@process) + (_.do "exit" (list (///runtime.i64//to-number codeJS)) @@process)) + (_.do "close" (list) @@window) + (_.do "reload" (list) @@location)))) + +(def: (io//current-time _) + Nullary + (|> (_.new (_.var "Date") (list)) + (_.do "getTime" (list)) + ///runtime.i64//from-number)) + +## [Bundles] +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.=))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: bit-procs + Bundle + (<| (bundle.prefix "bit") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry ///runtime.i64//and))) + (bundle.install "or" (binary (product.uncurry ///runtime.i64//or))) + (bundle.install "xor" (binary (product.uncurry ///runtime.i64//xor))) + (bundle.install "left-shift" (binary bit//left-shift)) + (bundle.install "logical-right-shift" (binary bit//logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) + ))) + +(def: int-procs + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry ///runtime.i64//+))) + (bundle.install "-" (binary (product.uncurry ///runtime.i64//-))) + (bundle.install "*" (binary (product.uncurry ///runtime.i64//*))) + (bundle.install "/" (binary (product.uncurry ///runtime.i64///))) + (bundle.install "%" (binary (product.uncurry ///runtime.i64//%))) + (bundle.install "=" (binary (product.uncurry ///runtime.i64//=))) + (bundle.install "<" (binary (product.uncurry ///runtime.i64//<))) + (bundle.install "to-frac" (unary ///runtime.i64//to-number)) + (bundle.install "char" (unary int//char))))) + +(def: frac-procs + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "smallest" (nullary frac//smallest)) + (bundle.install "min" (nullary frac//min)) + (bundle.install "max" (nullary frac//max)) + (bundle.install "to-int" (unary ///runtime.i64//from-number)) + (bundle.install "encode" (unary (_.do "toString" (list)))) + (bundle.install "decode" (unary frac//decode))))) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "concat" (binary text//concat)) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary (_.the "length"))) + (bundle.install "char" (binary (product.uncurry ///runtime.text//char))) + (bundle.install "clip" (trinary text//clip)) + ))) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary io//log)) + (bundle.install "error" (unary ///runtime.io//error)) + (bundle.install "exit" (unary io//exit)) + (bundle.install "current-time" (nullary io//current-time))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux-procs + (dictionary.merge bit-procs) + (dictionary.merge int-procs) + (dictionary.merge frac-procs) + (dictionary.merge text-procs) + (dictionary.merge io-procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux new file mode 100644 index 000000000..637cadc5f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux @@ -0,0 +1,120 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]] + [data + ["." product] + [collection + ["." dictionary]]] + [host + ["_" js]]] + [// + ["." common (#+ Nullary Binary Trinary Variadic)] + [// + ["///." runtime (#+ Handler Bundle)] + ["//." /// + ["." synthesis] + ["." extension + ["." bundle]]]]]) + +(do-template [<name> <js>] + [(def: (<name> _) Nullary <js>)] + + [js//null _.null] + [js//undefined _.undefined] + [js//object (_.object (list))] + ) + +(def: (js//global name translate inputs) + Handler + (case inputs + (^ (list (synthesis.text global))) + (:: /////.monad wrap (_.var global)) + + _ + (/////.throw extension.incorrect-syntax name))) + +(def: (js//call name translate inputs) + Handler + (case inputs + (^ (list& functionS argsS+)) + (do /////.monad + [functionJS (translate functionS) + argsJS+ (monad.map @ translate argsS+)] + (wrap (_.apply/* functionJS argsJS+))) + + _ + (/////.throw extension.incorrect-syntax name))) + +(def: js + Bundle + (|> bundle.empty + (bundle.install "null" (common.nullary js//null)) + (bundle.install "undefined" (common.nullary js//undefined)) + (bundle.install "object" (common.nullary js//object)) + (bundle.install "array" (common.variadic _.array)) + (bundle.install "global" js//global) + (bundle.install "call" js//call))) + +(def: (object//new name translate inputs) + Handler + (case inputs + (^ (list& constructorS argsS+)) + (do /////.monad + [constructorJS (translate constructorS) + argsJS+ (monad.map @ translate argsS+)] + (wrap (_.new constructorJS argsJS+))) + + _ + (/////.throw extension.incorrect-syntax name))) + +(def: (object//call name translate inputs) + Handler + (case inputs + (^ (list& objectS methodS argsS+)) + (do /////.monad + [objectJS (translate objectS) + methodJS (translate methodS) + argsJS+ (monad.map @ translate argsS+)] + (wrap (|> objectJS + (_.at methodJS) + (_.do "apply" (list& objectJS argsJS+))))) + + _ + (/////.throw extension.incorrect-syntax name))) + +(def: (object//set [fieldJS valueJS objectJS]) + Trinary + (///runtime.js//set objectJS fieldJS valueJS)) + +(def: object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "new" object//new) + (bundle.install "call" object//call) + (bundle.install "read" (common.binary (product.uncurry ///runtime.js//get))) + (bundle.install "write" (common.trinary object//set)) + (bundle.install "delete" (common.binary (product.uncurry ///runtime.js//delete))) + ))) + +(def: (array//write [indexJS valueJS arrayJS]) + Trinary + (///runtime.array//write indexJS valueJS arrayJS)) + +(def: array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "read" (common.binary (product.uncurry ///runtime.array//read))) + (bundle.install "write" (common.trinary array//write)) + (bundle.install "delete" (common.binary (product.uncurry ///runtime.array//delete))) + (bundle.install "length" (common.unary (_.the "length"))) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "js") + (|> ..js + (dictionary.merge ..object) + (dictionary.merge ..array)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux index f2bee19c5..ff72b1ac6 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux @@ -7,12 +7,12 @@ ["." i64] ["." frac]]] [host - ["_" js (#+ Expression)]]] + ["_" js (#+ Computation)]]] [// ["//." runtime]]) (def: #export bit - (-> Bit Expression) + (-> Bit Computation) _.boolean) (def: high @@ -25,12 +25,12 @@ (|>> (i64.and mask)))) (def: #export (i64 value) - (-> (I64 Any) Expression) + (-> (I64 Any) Computation) (//runtime.i64//new (|> value ..high .int _.i32) (|> value ..low .int _.i32))) (def: #export f64 - (-> Frac Expression) + (-> Frac Computation) (|>> (cond> [(f/= frac.positive-infinity)] [(new> _.positive-infinity [])] @@ -44,5 +44,5 @@ [_.number]))) (def: #export text - (-> Text Expression) + (-> Text Computation) _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux index c8e86dcb5..a7b8a5a05 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux @@ -149,8 +149,7 @@ (runtime: (lux//program-args) (with-vars [process output idx] - (_.if (_.and (_.not (_.= (_.type-of process) - _.undefined)) + (_.if (_.and (|> process _.type-of (_.= _.undefined) _.not) (|> process (_.the "argv"))) ($_ _.then (_.define output ..none) @@ -671,9 +670,11 @@ (runtime: (js//get object field) (with-vars [temp] - (_.if (|> temp (_.= _.undefined) _.not) - (_.return (..some temp)) - (_.return ..none)))) + ($_ _.then + (_.define temp (_.at field object)) + (_.if (_.= _.undefined temp) + (_.return ..none) + (_.return (..some temp)))))) (runtime: (js//set object field input) ($_ _.then @@ -685,18 +686,46 @@ (_.delete (_.at field object)) (_.return object))) -(runtime: (js//call object method inputs) - (_.return (_.apply/2 (_.at method object) object inputs))) - (def: runtime//js Statement ($_ _.then @js//get @js//set @js//delete - @js//call )) +(runtime: (array//read idx array) + (let [fail! (_.return ..none)] + (_.if (_.< (_.the "length" array) idx) + (with-vars [temp] + ($_ _.then + (_.define temp (_.at idx array)) + (_.if (_.= _.undefined temp) + fail! + (_.return (..some temp))))) + fail!))) + +(runtime: (array//write idx value array) + (_.if (_.< (_.the "length" array) idx) + ($_ _.then + (_.set (_.at idx array) value) + (_.return (..some array))) + (_.return ..none))) + +(runtime: (array//delete idx array) + (_.if (_.< (_.the "length" array) idx) + ($_ _.then + (_.delete (_.at idx array)) + (_.return (..some array))) + (_.return ..none))) + +(def: runtime//array + Statement + ($_ _.then + @array//read + @array//write + @array//delete)) + (def: runtime Statement ($_ _.then @@ -706,6 +735,7 @@ runtime//text runtime//io runtime//js + runtime//array )) (def: #export artifact Text (format prefix ".js")) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux index 1c55abf83..d430aba24 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux @@ -15,16 +15,14 @@ ["." macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax:)]] - [host (#+ import:)]] + [host (#+ import:) + ["_" scheme (#+ Expression Computation)]]] [/// ["." runtime (#+ Operation Phase Handler Bundle)] ["//." /// ["." synthesis (#+ Synthesis)] ["." extension - ["." bundle]] - [/// - [host - ["_" scheme (#+ Expression Computation)]]]]]) + ["." bundle]]]]) (syntax: (Vector {size s.nat} elemT) (wrap (list (` [(~+ (list.repeat size elemT))])))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 7a76cd53b..c2ca8b3ba 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -5,7 +5,10 @@ [case (#+)] [loop (#+)] [function (#+)] - [expression (#+)])] + [expression (#+)] + [extension (#+) + [common (#+)] + [host (#+)]])] (.module: [lux #* [cli (#+ program:)] |