From 950ac7c3311ad8ff4499164a30610fca2e57d5c9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 21 Feb 2019 21:25:14 -0400 Subject: Moved extension machinery over. --- .../lang/translation/js/procedure/common.jvm.lux | 375 --------------------- .../lang/translation/js/procedure/host.jvm.lux | 149 -------- stdlib/source/lux/host/js.lux | 26 +- .../source/lux/tool/compiler/phase/extension.lux | 3 + .../compiler/phase/translation/js/extension.lux | 15 + .../phase/translation/js/extension/common.lux | 231 +++++++++++++ .../phase/translation/js/extension/host.lux | 120 +++++++ .../compiler/phase/translation/js/primitive.lux | 10 +- .../tool/compiler/phase/translation/js/runtime.lux | 48 ++- .../translation/scheme/extension/common.jvm.lux | 8 +- stdlib/source/test/lux.lux | 5 +- 11 files changed, 441 insertions(+), 549 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/js/procedure/host.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux deleted file mode 100644 index 641eb9e02..000000000 --- a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux +++ /dev/null @@ -1,375 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [js #+ JS Expression Statement]))) - [///] - (/// [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])) - -## [Types] -(type: #export Translator - (-> ls.Synthesis (Meta Expression))) - -(type: #export Proc - (-> Translator (List ls.Synthesis) (Meta Expression))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 Expression) Expression)) -(type: #export Unary (-> (Vector +1 Expression) Expression)) -(type: #export Binary (-> (Vector +2 Expression) Expression)) -(type: #export Trinary (-> (Vector +3 Expression) Expression)) -(type: #export Variadic (-> (List Expression) Expression)) - -## [Utils] -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected .int %i) "\n" - " Actual: " (|> actual .int %i))) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!proc g!name g!translate g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) - (-> Text ..Proc)) - (function ((~ g!_) (~ g!name)) - (function ((~ g!_) (~ g!translate) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do macro.Monad - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) - - (~' _) - (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic proc) - (-> Variadic (-> Text Proc)) - (function (_ proc-name) - (function (_ translate inputsS) - (do macro.Monad - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) - -(def: (self-contained content) - (-> Expression Expression) - (format "(" content ")")) - -(def: (void action) - (-> Expression Expression) - (format "(" action "," runtimeT.unit ")")) - -## [Procedures] -## [[Lux]] -(def: (lux//is [leftJS rightJS]) - Binary - (self-contained (format leftJS " === " rightJS))) - -(def: (lux//if [testJS thenJS elseJS]) - Trinary - (caseT.translate-if testJS thenJS elseJS)) - -(def: (lux//try riskyJS) - Unary - (format runtimeT.lux//try "(" riskyJS ")")) - -(exception: #export (Wrong-Syntax {message Text}) - message) - -(def: #export (wrong-syntax procedure args) - (-> Text (List ls.Synthesis) Text) - (format "Procedure: " procedure "\n" - "Arguments: " (%code (code.tuple args)))) - -(def: lux//loop - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) - (#e.Success [offset initsS+ bodyS]) - (loopT.translate-loop translate offset initsS+ bodyS) - - (#e.Error error) - (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) - ))) - -(def: lux//recur - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (loopT.translate-recur translate inputsS)))) - -## [[Bits]] -(do-template [ ] - [(def: ( [subjectJS paramJS]) - Binary - (format "(" subjectJS "," paramJS ")"))] - - [bit//and runtimeT.bit//and] - [bit//or runtimeT.bit//or] - [bit//xor runtimeT.bit//xor] - ) - -(do-template [ ] - [(def: ( [subjectJS paramJS]) - Binary - (let [simple-param (format runtimeT.int//to-number "(" paramJS ")")] - (format "(" subjectJS "," simple-param ")")))] - - [bit//left-shift runtimeT.bit//left-shift] - [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift] - [bit//logical-right-shift runtimeT.bit//logical-right-shift] - ) - -## [[Numbers]] -(host.import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(do-template [ ] - [(def: ( _) - Nullary - ( ))] - - [frac//smallest Double::MIN_VALUE runtimeT.frac] - [frac//min (f/* -1.0 Double::MAX_VALUE) runtimeT.frac] - [frac//max Double::MAX_VALUE runtimeT.frac] - ) - -(do-template [ ] - [(def: ( [subjectJS paramJS]) - Binary - (format "(" subjectJS "," paramJS ")"))] - - [int//add runtimeT.int//+] - [int//sub runtimeT.int//-] - [int//mul runtimeT.int//*] - [int//div runtimeT.int///] - [int//rem runtimeT.int//%] - ) - -(do-template [ ] - [(def: ( [subjectJS paramJS]) - Binary - (self-contained (format subjectJS " " " " paramJS)))] - - [frac//add "+"] - [frac//sub "-"] - [frac//mul "*"] - [frac//div "/"] - [frac//rem "%"] - [frac//= "==="] - [frac//< "<"] - - [text//= "==="] - [text//< "<"] - ) - -(do-template [ ] - [(def: ( [subjectJS paramJS]) - Binary - (format "(" subjectJS "," paramJS ")"))] - - [int//= runtimeT.int//=] - [int//< runtimeT.int//<] - ) - -(def: (frac//encode inputJS) - Unary - (format (self-contained inputJS) ".toString()")) - -(def: (frac//decode inputJS) - Unary - (let [decoding (format "parseFloat(" inputJS ")") - thunk (self-contained (format "function () { return " decoding "; }"))] - (lux//try thunk))) - -(do-template [ ] - [(def: ( inputJS) - Unary - (format "(" inputJS ")"))] - - [int//to-frac runtimeT.int//to-number] - [frac//to-int runtimeT.int//from-number] - ) - -(def: (int//char inputJS) - Unary - (format "String.fromCharCode" "(" (int//to-frac inputJS) ")")) - -## [[Text]] -(def: (text//size inputJS) - Unary - (format inputJS ".length")) - -(def: (text//concat [subjectJS paramJS]) - Binary - (format subjectJS "." "concat" "(" paramJS ")")) - -(def: (text//char [subjectJS paramJS]) - Binary - (format runtimeT.text//char "(" subjectJS "," paramJS ")")) - -(do-template [ ] - [(def: ( [subjectJS paramJS extraJS]) - Trinary - (format "(" subjectJS "," paramJS "," extraJS ")"))] - - [text//clip runtimeT.text//clip] - [text//index runtimeT.text//index] - - ) - -## [[IO]] -(def: (io//log messageJS) - Unary - (void (format runtimeT.io//log "(" messageJS ")"))) - -(def: (io//error messageJS) - Unary - (format runtimeT.io//error "(" messageJS ")")) - -(def: (io//exit codeJS) - Unary - (format "(" - (format "(!((typeof process) === \"undefined\") && process.exit && process.exit(" (int//to-frac codeJS) "))") - " || " - "window.close()" - " || " - "location.reload()" - ")")) - -(def: (io//current-time []) - Nullary - (frac//to-int "(new Date()).getTime()")) - -## [Bundles] -(def: lux-procs - Bundle - (|> (dict.new text.Hash) - (install "is" (binary lux//is)) - (install "try" (unary lux//try)) - (install "if" (trinary lux//if)) - (install "loop" lux//loop) - (install "recur" lux//recur) - )) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "left-shift" (binary bit//left-shift)) - (install "logical-right-shift" (binary bit//logical-right-shift)) - (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) - ))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash) - (install "+" (binary int//add)) - (install "-" (binary int//sub)) - (install "*" (binary int//mul)) - (install "/" (binary int//div)) - (install "%" (binary int//rem)) - (install "=" (binary int//=)) - (install "<" (binary int//<)) - (install "to-frac" (unary int//to-frac)) - (install "char" (unary int//char))))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash) - (install "+" (binary frac//add)) - (install "-" (binary frac//sub)) - (install "*" (binary frac//mul)) - (install "/" (binary frac//div)) - (install "%" (binary frac//rem)) - (install "=" (binary frac//=)) - (install "<" (binary frac//<)) - (install "smallest" (nullary frac//smallest)) - (install "min" (nullary frac//min)) - (install "max" (nullary frac//max)) - (install "to-int" (unary frac//to-int)) - (install "encode" (unary frac//encode)) - (install "decode" (unary frac//decode))))) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash) - (install "=" (binary text//=)) - (install "<" (binary text//<)) - (install "concat" (binary text//concat)) - (install "index" (trinary text//index)) - (install "size" (unary text//size)) - (install "char" (binary text//char)) - (install "clip" (trinary text//clip)) - ))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash) - (install "log" (unary io//log)) - (install "error" (unary io//error)) - (install "exit" (unary io//exit)) - (install "current-time" (nullary io//current-time))))) - -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> lux-procs - (dict.merge bit-procs) - (dict.merge int-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge io-procs) - ))) diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/host.jvm.lux deleted file mode 100644 index 00c2429a4..000000000 --- a/new-luxc/source/luxc/lang/translation/js/procedure/host.jvm.lux +++ /dev/null @@ -1,149 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis])) - [///] - (/// [".T" runtime]) - (// ["@" common])) - -(do-template [ ] - [(def: ( _) @.Nullary )] - - [js//null "null"] - [js//undefined "undefined"] - [js//object "{}"] - ) - -(def: (js//global proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text name)])) - (do macro.Monad - [] - (wrap name)) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (js//call proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& functionS argsS+)) - (do macro.Monad - [functionJS (translate functionS) - argsJS+ (monad.map @ translate argsS+)] - (wrap (format "(" functionJS ")(" - (text.join-with "," argsJS+) - ")"))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: js-procs - @.Bundle - (|> (dict.new text.Hash) - (@.install "null" (@.nullary js//null)) - (@.install "undefined" (@.nullary js//undefined)) - (@.install "object" (@.nullary js//object)) - (@.install "global" js//global) - (@.install "call" js//call))) - -(def: (object//new proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& constructorS argsS+)) - (do macro.Monad - [constructorJS (translate constructorS) - argsJS+ (monad.map @ translate argsS+)] - (wrap (format "new (" constructorJS ")(" - (text.join-with "," argsJS+) - ")"))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (object//call proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& objectS fieldS argsS+)) - (do macro.Monad - [objectJS (translate objectS) - fieldJS (translate fieldS) - argsJS+ (monad.map @ translate argsS+)] - (wrap (format runtimeT.js//call - "(" objectJS - "," fieldJS - "," "[" (text.join-with "," argsJS+) "]" - ")"))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (object//get [fieldJS objectJS]) - @.Binary - (format runtimeT.js//get "(" objectJS "," fieldJS ")")) - -(def: (object//set [fieldJS valueJS objectJS]) - @.Trinary - (format runtimeT.js//set "(" objectJS "," fieldJS "," valueJS ")")) - -(def: (object//delete [fieldJS objectJS]) - @.Binary - (format runtimeT.js//delete "(" objectJS "," fieldJS ")")) - -(def: object-procs - @.Bundle - (<| (@.prefix "object") - (|> (dict.new text.Hash) - (@.install "new" object//new) - (@.install "call" object//call) - (@.install "get" (@.binary object//get)) - (@.install "set" (@.trinary object//set)) - (@.install "delete" (@.binary object//delete)) - ))) - -(def: (array//literal elementsJS+) - @.Variadic - (format "[" (text.join-with "," elementsJS+) "]")) - -(def: (array//read [indexJS arrayJS]) - @.Binary - (format runtimeT.array//get "(" arrayJS "," indexJS ")")) - -(def: (array//write [indexJS valueJS arrayJS]) - @.Trinary - (format runtimeT.array//put "(" arrayJS "," indexJS "," valueJS ")")) - -(def: (array//delete [indexJS arrayJS]) - @.Binary - (format runtimeT.array//remove "(" arrayJS "," indexJS ")")) - -(def: (array//length arrayJS) - @.Unary - (format arrayJS ".length")) - -(def: array-procs - @.Bundle - (<| (@.prefix "array") - (|> (dict.new text.Hash) - (@.install "literal" (@.variadic array//literal)) - (@.install "read" (@.binary array//read)) - (@.install "write" (@.trinary array//write)) - (@.install "delete" (@.binary array//delete)) - (@.install "length" (@.unary array//length)) - ))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "js") - (|> js-procs - (dict.merge object-procs) - (dict.merge array-procs) - ))) 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 (|> Any (~~ (template.splice +)))))] [Expression Expression' [Code]] - [Location Location' [Expression' Code]] + [Computation Computation' [Expression' Code]] + [Location Location' [Computation' Expression' Code]] ) (do-template [ +] [(abstract: #export {} Any) (`` (type: #export (|> (~~ (template.splice +)))))] - [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 [ ] + [(def: ( [subjectJS paramJS]) + Binary + ( 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 [ ] + [(def: ( _) + Nullary + (///primitive.f64 ))] + + [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 [ ] + [(def: ( [subjectJS paramJS extraJS]) + Trinary + ( 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 [ ] + [(def: ( _) Nullary )] + + [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:)] -- cgit v1.2.3