diff options
11 files changed, 591 insertions, 190 deletions
diff --git a/stdlib/source/lux/debug.lux b/stdlib/source/lux/debug.lux index 59b35a223..316617d84 100644 --- a/stdlib/source/lux/debug.lux +++ b/stdlib/source/lux/debug.lux @@ -1,5 +1,6 @@ (.module: [lux #* + ["@" target] ["." type] ["." host (#+ import:)] [abstract @@ -16,9 +17,9 @@ format] [format [xml (#+ XML)] - [json (#+ JSON)]] + ["." json]] [collection - ["." array (#+ Array)] + ["." array] ["." list ("#@." functor)]]] [time [instant (#+ Instant)] @@ -27,69 +28,126 @@ [macro ["." template]]]) -(import: #long java/lang/String) +(with-expansions [<for-jvm> (as-is (import: #long java/lang/String) -(import: #long (java/lang/Class a) - (getCanonicalName [] java/lang/String)) + (import: #long (java/lang/Class a) + (getCanonicalName [] java/lang/String)) -(import: #long java/lang/Object - (new []) - (toString [] java/lang/String) - (getClass [] (java/lang/Class java/lang/Object))) + (import: #long java/lang/Object + (new []) + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))) -(import: #long java/lang/Integer - (longValue [] long)) + (import: #long java/lang/Integer + (longValue [] long)) -(import: #long java/lang/Long - (intValue [] int)) + (import: #long java/lang/Long + (intValue [] int)) -(import: #long java/lang/Number - (intValue [] int) - (longValue [] long) - (doubleValue [] double)) + (import: #long java/lang/Number + (intValue [] int) + (longValue [] long) + (doubleValue [] double)))] + (`` (for {(~~ (static @.old)) + (as-is <for-jvm>) + + (~~ (static @.jvm)) + (as-is <for-jvm>) + + (~~ (static @.js)) + (as-is (import: JSON + (#static stringify [.Any] host.String)) + (import: Array + (#static isArray [.Any] host.Boolean)))}))) + +(type: Inspector (-> Any Text)) + +(def: (inspect-tuple inspect) + (-> Inspector Inspector) + (|>> (:coerce (array.Array Any)) + array.to-list + (list@map inspect) + (text.join-with " ") + (text.enclose ["[" "]"]))) (def: #export (inspect value) - (-> Any Text) - (let [object (:coerce java/lang/Object value)] - (`` (<| (~~ (template [<class> <processing>] - [(case (host.check <class> object) - (#.Some value) - (`` (|> value (~~ (template.splice <processing>)))) - #.None)] - - [java/lang/Boolean [(:coerce .Bit) %b]] - [java/lang/String [(:coerce .Text) %t]] - [java/lang/Long [(:coerce .Int) %i]] - [java/lang/Number [java/lang/Number::doubleValue %f]] - )) - (case (host.check [java/lang/Object] object) - (#.Some value) - (let [value (:coerce (Array java/lang/Object) value)] - (case (array.read 0 value) - (^multi (#.Some tag) - [(host.check java/lang/Integer tag) - (#.Some tag)] - [[(array.read 1 value) - (array.read 2 value)] - [last? - (#.Some choice)]]) - (let [last? (case last? - (#.Some _) #1 - #.None #0)] - (|> (format (%n (.nat (java/lang/Integer::longValue tag))) - " " (%b last?) - " " (inspect choice)) - (text.enclose ["(" ")"]))) - - _ - (|> value - array.to-list - (list@map inspect) - (text.join-with " ") - (text.enclose ["[" "]"])))) - #.None) - (java/lang/Object::toString object))) - )) + Inspector + (with-expansions [<for-jvm> (let [object (:coerce java/lang/Object value)] + (`` (<| (~~ (template [<class> <processing>] + [(case (host.check <class> object) + (#.Some value) + (`` (|> value (~~ (template.splice <processing>)))) + #.None)] + + [java/lang/Boolean [(:coerce .Bit) %b]] + [java/lang/String [(:coerce .Text) %t]] + [java/lang/Long [(:coerce .Int) %i]] + [java/lang/Number [java/lang/Number::doubleValue %f]] + )) + (case (host.check [java/lang/Object] object) + (#.Some value) + (let [value (:coerce (array.Array java/lang/Object) value)] + (case (array.read 0 value) + (^multi (#.Some tag) + [(host.check java/lang/Integer tag) + (#.Some tag)] + [[(array.read 1 value) + (array.read 2 value)] + [last? + (#.Some choice)]]) + (let [last? (case last? + (#.Some _) #1 + #.None #0)] + (|> (format (%n (.nat (java/lang/Integer::longValue tag))) + " " (%b last?) + " " (inspect choice)) + (text.enclose ["(" ")"]))) + + _ + (inspect-tuple inspect value))) + #.None) + (java/lang/Object::toString object))))] + (`` (for {(~~ (static @.old)) + <for-jvm> + + (~~ (static @.jvm)) + <for-jvm> + + (~~ (static @.js)) + (~~ (case (host.type-of value) + (^template [<type-of> <then>] + <type-of> + (`` (|> value (~~ (template.splice <then>))))) + (["boolean" [(:coerce .Bit) %b]] + ["string" [(:coerce .Text) %t]] + ["number" [(:coerce .Frac) %f]] + ["undefined" [JSON::stringify]]) + + "object" + (let [variant-tag ("js object get" "_lux_tag" value) + variant-flag ("js object get" "_lux_flag" value) + variant-value ("js object get" "_lux_value" value)] + (cond (not (or ("js object undefined?" variant-tag) + ("js object undefined?" variant-flag) + ("js object undefined?" variant-value))) + (|> (format (JSON::stringify variant-tag) + " " (%b (not ("js object null?" variant-flag))) + " " (inspect variant-value)) + (text.enclose ["(" ")"])) + + (not (or ("js object undefined?" ("js object get" "_lux_low" value)) + ("js object undefined?" ("js object get" "_lux_high" value)))) + (|> value (:coerce .Int) %i) + + (Array::isArray value) + (inspect-tuple inspect value) + + ## else + (JSON::stringify value))) + + _ + (undefined))) + })))) (exception: #export (cannot-represent-value {type Type}) (exception.report @@ -129,7 +187,7 @@ [Instant %instant] [Duration %duration] [Date %date] - [JSON %json] + [json.JSON %json] [XML %xml])) (do <>.monad diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 20dc2ed5e..7e0f64e4d 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -3,6 +3,7 @@ [abstract [monad (#+ do)]] [control + ["." io] ["<>" parser ["<c>" code (#+ Parser)]]] [data @@ -34,9 +35,9 @@ (template [<name> <type>] [(type: #export <name> <type>)] - [String Text] - [Number Frac] [Boolean Bit] + [Number Frac] + [String Text] ) (type: Nullable [Bit Code]) @@ -63,14 +64,29 @@ <c>.local-identifier ..nullable))) -(type: Method [Text (List Nullable) Nullable]) +(type: Common-Method [Text (List Nullable) Bit Nullable]) +(type: Static-Method Common-Method) +(type: Virtual-Method Common-Method) + +(type: Method + (#Static Static-Method) + (#Virtual Virtual-Method)) + +(def: common-method + (Parser Common-Method) + ($_ <>.and + <c>.local-identifier + (<c>.tuple (<>.some ..nullable)) + (<>.parses? (<c>.this! (' #try))) + ..nullable)) + +(def: static-method + (<c>.form (<>.after (<c>.this! (' #static)) ..common-method))) (def: method (Parser Method) - (<c>.form ($_ <>.and - <c>.local-identifier - (<c>.tuple (<>.some ..nullable)) - ..nullable))) + (<>.or ..static-method + (<c>.form ..common-method))) (type: Member (#Constructor Constructor) @@ -117,47 +133,126 @@ (#.Some (~ g!temp))))) output)) -(syntax: #export (import: {class <c>.local-identifier} - {members (<>.some member)}) - (with-gensyms [g!object g!temp] - (let [g!type (code.local-identifier class) - qualify (: (-> Text Code) - (|>> (format class "::") code.local-identifier))] - (wrap (list& (` (type: (~ g!type) (..Object (primitive (~ (code.text class)))))) - (list@map (function (_ member) - (case member - (#Constructor inputsT) - (let [g!inputs (input-variables inputsT)] - (` (def: ((~ (qualify "new")) - [(~+ (list@map product.right g!inputs))]) - (-> [(~+ (list@map nullable-type inputsT))] - (~ g!type)) - (:assume - ("js object new" - ("js constant" (~ (code.text class))) - [(~+ (list@map (with-null g!temp) g!inputs))]))))) - - (#Field [field fieldT]) - (` (def: ((~ (qualify field)) - (~ g!object)) - (-> (~ g!type) - (~ (nullable-type fieldT))) - (:assume - (~ (without-null g!temp fieldT (` ("js object get" (~ (code.text field)) (~ g!object)))))))) - - (#Method [method inputsT outputT]) - (let [g!inputs (input-variables inputsT)] - (` (def: ((~ (qualify method)) - [(~+ (list@map product.right g!inputs))] - (~ g!object)) - (-> [(~+ (list@map nullable-type inputsT))] - (~ g!type) - (~ (nullable-type outputT))) - (:assume - (~ (without-null g!temp - outputT - (` ("js object do" - (~ (code.text method)) - (~ g!object) - [(~+ (list@map (with-null g!temp) g!inputs))])))))))))) - members)))))) +(type: Import + (#Class [Text (List Member)]) + (#Function Static-Method)) + +(def: import + ($_ <>.or + ($_ <>.and + <c>.local-identifier + (<>.some member)) + ..static-method + )) + +(def: (with-try try? without-try) + (-> Bit Code Code) + (if try? + (` ("lux try" + ((~! io.io) (~ without-try)))) + without-try)) + +(def: (try-type try? rawT) + (-> Bit Code Code) + (if try? + (` (.Either .Text (~ rawT))) + rawT)) + +(def: (make-function g!method g!temp source inputsT try? outputT) + (-> Code Code Text (List Nullable) Bit Nullable Code) + (let [g!inputs (input-variables inputsT)] + (` (def: ((~ g!method) + [(~+ (list@map product.right g!inputs))]) + (-> [(~+ (list@map nullable-type inputsT))] + (~ (try-type try? (nullable-type outputT)))) + (:assume + (~ (<| (with-try try?) + (without-null g!temp outputT) + (` ("js apply" + ("js constant" (~ (code.text source))) + (~+ (list@map (with-null g!temp) g!inputs))))))))))) + +(syntax: #export (import: {import ..import}) + (with-gensyms [g!temp] + (case import + (#Class [class members]) + (with-gensyms [g!object] + (let [qualify (: (-> Text Code) + (|>> (format class "::") code.local-identifier)) + g!type (code.local-identifier class)] + (wrap (list& (` (type: (~ g!type) (..Object (primitive (~ (code.text class)))))) + (list@map (function (_ member) + (case member + (#Constructor inputsT) + (let [g!inputs (input-variables inputsT)] + (` (def: ((~ (qualify "new")) + [(~+ (list@map product.right g!inputs))]) + (-> [(~+ (list@map nullable-type inputsT))] + (~ g!type)) + (:assume + ("js object new" + ("js constant" (~ (code.text class))) + [(~+ (list@map (with-null g!temp) g!inputs))]))))) + + (#Field [field fieldT]) + (` (def: ((~ (qualify field)) + (~ g!object)) + (-> (~ g!type) + (~ (nullable-type fieldT))) + (:assume + (~ (without-null g!temp fieldT (` ("js object get" (~ (code.text field)) (~ g!object)))))))) + + (#Method method) + (case method + (#Static [method inputsT try? outputT]) + (make-function (qualify method) g!temp method inputsT try? outputT) + + (#Virtual [method inputsT try? outputT]) + (let [g!inputs (input-variables inputsT)] + (` (def: ((~ (qualify method)) + [(~+ (list@map product.right g!inputs))] + (~ g!object)) + (-> [(~+ (list@map nullable-type inputsT))] + (~ g!type) + (~ (try-type try? (nullable-type outputT)))) + (:assume + (~ (<| (with-try try?) + (without-null g!temp outputT) + (` ("js object do" + (~ (code.text method)) + (~ g!object) + [(~+ (list@map (with-null g!temp) g!inputs))]))))))))))) + members))))) + + (#Function [name inputsT try? outputT]) + (wrap (list (make-function (code.local-identifier name) g!temp name inputsT try? outputT))) + ))) + +(syntax: #export (type-of object) + (wrap (list (` ("js type-of" (~ object)))))) + +(def: #export on-browser? + Bit + (case (..type-of ("js constant" "window")) + "undefined" + false + + _ + true)) + +(def: #export on-node-js? + Bit + (case (..type-of ("js constant" "process")) + "undefined" + false + + _ + (case (:coerce .Text + ("js apply" + ("js constant" "Object.prototype.toString.call") + ("js constant" "process"))) + "[object process]" + true + + _ + false))) diff --git a/stdlib/source/lux/target/js.lux b/stdlib/source/lux/target/js.lux index c89d59415..e0912251c 100644 --- a/stdlib/source/lux/target/js.lux +++ b/stdlib/source/lux/target/js.lux @@ -1,8 +1,10 @@ (.module: - [lux (#- Code or and function if cond undefined for comment false true not) + [lux (#- Code or and function if cond undefined for comment not int) [control [pipe (#+ case>)]] [data + [number + ["." frac]] ["." text format] [collection @@ -40,31 +42,39 @@ [Var Var' [Location' Computation' Expression' Code]] [Access Access' [Location' Computation' Expression' Code]] + [Literal Literal' [Computation' Expression' Code]] [Loop Loop' [Statement' Code]] [Label Label' [Code]] ) (template [<name> <literal>] - [(def: #export <name> Computation (:abstraction <literal>))] + [(def: #export <name> Literal (:abstraction <literal>))] [null "null"] [undefined "undefined"] - [false "false"] - [true "true"] - [positive-infinity "Infinity"] - [negative-infinity "-Infinity"] - [not-a-number "NaN"] ) (def: #export boolean - (-> Bit Computation) + (-> Bit Literal) (|>> (case> - #0 ..false - #1 ..true))) + #0 "false" + #1 "true") + :abstraction)) + + (def: #export (number value) + (-> Frac Literal) + (:abstraction + (.cond (frac.not-a-number? value) + "NaN" + + (f/= frac.positive-infinity value) + "Infinity" + + (f/= frac.negative-infinity value) + "-Infinity" - (def: #export number - (-> Frac Computation) - (|>> %f ..argument :abstraction)) + ## else + (|> value %f ..argument)))) (def: sanitize (-> Text Text) @@ -84,7 +94,7 @@ ))) (def: #export string - (-> Text Computation) + (-> Text Literal) (|>> ..sanitize (text.enclose [text.double-quote text.double-quote]) :abstraction)) @@ -235,6 +245,12 @@ [i32 Int %i] ) + (def: #export (int value) + (-> Int Literal) + (:abstraction (.if (i/< +0 value) + (%i value) + (%n (.nat value))))) + (def: #export (? test then else) (-> Expression Expression Expression Computation) (|> (format (:representation test) @@ -372,6 +388,27 @@ (def: #export (comment commentary on) (All [kind] (-> Text (Code kind) (Code kind))) (:abstraction (format "/* " commentary " */" " " (:representation on)))) + + (def: #export (switch input cases default) + (-> Expression (List [(List Literal) Statement]) (Maybe Statement) Statement) + (:abstraction (format "switch (" (:representation input) ")" text.new-line + (|> (format (|> cases + (list@map (.function (_ [when then]) + (format (|> when + (list@map (|>> :representation (text.enclose ["case " ":"]))) + (text.join-with text.new-line)) + text.new-line + (:representation then)))) + (text.join-with text.new-line)) + text.new-line + (case default + (#.Some default) + (format "default:" text.new-line + (:representation default)) + + #.None "")) + :abstraction + ..block)))) ) (def: #export (cond clauses else!) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux index d04e04ec9..0b9c4de2f 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux @@ -175,12 +175,24 @@ _ (typeA.infer Any)] (wrap (#/////analysis.Extension extension (list& abstractionA inputsA)))))])) +(def: js::type-of + Handler + (custom + [<c>.any + (function (_ extension phase objectC) + (do ////.monad + [objectA (typeA.with-type Any + (phase objectC)) + _ (typeA.infer .Text)] + (wrap (#/////analysis.Extension extension (list objectA)))))])) + (def: #export bundle Bundle (<| (///bundle.prefix "js") (|> ///bundle.empty (///bundle.install "constant" js::constant) (///bundle.install "apply" js::apply) + (///bundle.install "type-of" js::type-of) (dictionary.merge bundle::array) (dictionary.merge bundle::object) ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux index 9e066b88d..3a5e8f2d3 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux @@ -125,7 +125,7 @@ (def: (alternation pre! post!) (-> Statement Statement Statement) ($_ _.then - (_.do-while _.false + (_.do-while (_.boolean false) ($_ _.then ..save-cursor! pre!)) @@ -225,7 +225,7 @@ (do ////.monad [pattern-matching! (pattern-matching' generate pathP)] (wrap ($_ _.then - (_.do-while _.false + (_.do-while (_.boolean false) pattern-matching!) (_.throw (_.string case.pattern-matching-error)))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux index c9dc64547..f2d22f57b 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux @@ -3,21 +3,41 @@ [host (#+ import:)] [abstract ["." monad (#+ do)]] + [control + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] [data ["." product] + ["." error] [collection + ["." list ("#@." functor)] ["." dictionary]]] [target - ["_" js (#+ Expression)]]] + ["_" js (#+ Literal Expression Statement)]]] ["." /// #_ ["#." runtime (#+ Operation Phase Handler Bundle)] ["#." primitive] - [// + ["/#" // #_ [extension (#+ Nullary Unary Binary Trinary nullary unary binary trinary)] - [// - [extension - ["." bundle]]]]]) + ["/#" // + ["." extension + ["." bundle]] + [// + [synthesis (#+ %synthesis)]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation Expression))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run input parser) + (#error.Success input') + (handler extension-name phase input') + + (#error.Failure error) + (/////.throw extension.invalid-syntax [extension-name %synthesis input])))) ## [Procedures] ## [[Bits]] @@ -99,10 +119,37 @@ (_.do "getTime" (list)) ///runtime.i64//from-number)) +## TODO: Get rid of this ASAP +(def: lux::syntax-char-case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension-name phase [input else conditionals]) + (do /////.monad + [inputG (phase input) + elseG (phase else) + conditionalsG (: (Operation (List [(List Literal) + Statement])) + (monad.map @ (function (_ [chars branch]) + (do @ + [branchG (phase branch)] + (wrap [(list@map (|>> .int _.int) chars) + (_.return branchG)]))) + conditionals))] + (wrap (_.apply/* (_.closure (list) + (_.switch (_.the ///runtime.i64-low-field inputG) + conditionalsG + (#.Some (_.return elseG)))) + (list)))))])) + ## [Bundles] (def: lux-procs Bundle (|> bundle.empty + (bundle.install "syntax char case!" lux::syntax-char-case!) (bundle.install "is" (binary (product.uncurry _.=))) (bundle.install "try" (unary ///runtime.lux//try)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux index bb3d6138d..423f0a58d 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux @@ -13,7 +13,7 @@ [target ["_" js (#+ Expression)]]] ["." // #_ - ["#." common] + ["#." common (#+ custom)] ["/#" // #_ ["#." runtime (#+ Operation Phase Handler Bundle with-vars)] @@ -23,22 +23,7 @@ nullary unary binary trinary)] ["/#" // ["." extension - ["." bundle]] - [// - [synthesis (#+ %synthesis)]]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase s (Operation Expression))] - Handler)) - (function (_ extension-name phase input) - (case (<s>.run input parser) - (#error.Success input') - (handler extension-name phase input') - - (#error.Failure error) - (/////.throw extension.invalid-syntax [extension-name %synthesis input])))) + ["." bundle]]]]]]) (def: array::new (Unary Expression) @@ -72,7 +57,7 @@ ))) (def: object::new - (..custom + (custom [($_ <>.and <s>.any (<>.some <s>.any)) (function (_ extension phase [constructorS inputsS]) (do /////.monad @@ -121,7 +106,7 @@ ))) (def: js::constant - (..custom + (custom [<s>.text (function (_ extension phase name) (do /////.monad @@ -129,7 +114,7 @@ (wrap (_.var name))))])) (def: js::apply - (..custom + (custom [($_ <>.and <s>.any (<>.some <s>.any)) (function (_ extension phase [abstractionS inputsS]) (do /////.monad @@ -143,6 +128,7 @@ (|> bundle.empty (bundle.install "constant" js::constant) (bundle.install "apply" js::apply) + (bundle.install "type-of" (unary _.type-of)) (dictionary.merge ..array) (dictionary.merge ..object) ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux index 6b1e32a36..da1052d28 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux @@ -10,29 +10,13 @@ ["." // #_ ["#." runtime]]) -(def: #export bit - (-> Bit Computation) - _.boolean) +(def: #export bit _.boolean) (def: #export (i64 value) (-> (I64 Any) Computation) (//runtime.i64//new (|> value //runtime.high .int _.i32) (|> value //runtime.low .int _.i32))) -(def: #export f64 - (-> Frac Computation) - (|>> (cond> [(f/= frac.positive-infinity)] - [(new> _.positive-infinity [])] - - [(f/= frac.negative-infinity)] - [(new> _.negative-infinity [])] - - [(f/= frac.not-a-number)] - [(new> _.not-a-number [])] - - ## else - [_.number]))) +(def: #export f64 _.number) -(def: #export text - (-> Text Computation) - _.string) +(def: #export text _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux index 54a15b036..6bd6565dd 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux @@ -240,8 +240,8 @@ @sum//get )) -(def: #export i64-high-field Text "_lux_high") (def: #export i64-low-field Text "_lux_low") +(def: #export i64-high-field Text "_lux_high") (runtime: (i64//new high low) (_.return (_.object (list [..i64-high-field high] @@ -494,9 +494,9 @@ (_.define -subject? (negative? subject)) (_.define -parameter? (negative? parameter)) (_.cond (list [(_.and -subject? (_.not -parameter?)) - (_.return _.true)] + (_.return (_.boolean true))] [(_.and (_.not -subject?) -parameter?) - (_.return _.false)]) + (_.return (_.boolean false))]) (_.return (negative? (i64//- parameter subject)))))))) (def: (i64//<= param subject) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index f60bb6974..230b30f79 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -1,6 +1,6 @@ (.module: [lux #* - [host (#+ import:)] + ["." host (#+ import:)] ["@" target] [abstract ["." monad (#+ Monad do)]] @@ -12,13 +12,14 @@ [security ["!" capability (#+ capability:)]]] [data + ["." product] ["." maybe] ["." error (#+ Error) ("#;." functor)] ["." text format] [collection - ["." array] - ["." list ("#;." functor)]]] + ["." array (#+ Array)] + ["." list ("#@." functor)]]] [time ["." instant (#+ Instant)] ["." duration]] @@ -120,7 +121,7 @@ (`` (structure (~~ (template [<name> <async>] [(def: <name> (..can-query (|>> (!.use (:: directory <name>)) - (io;map (error;map (list;map <async>))) + (io;map (error;map (list@map <async>))) promise.future)))] [files ..async-file] @@ -175,17 +176,17 @@ [not-a-directory] ) -(exception: #export (cannot-move {target Path} {source Path}) - (exception.report - ["Source" source] - ["Target" target])) +(with-expansions [<for-jvm> (as-is (exception: #export (cannot-move {target Path} {source Path}) + (exception.report + ["Source" source] + ["Target" target])) -(exception: #export (cannot-modify {instant Instant} {file Path}) - (exception.report - ["Instant" (%instant instant)] - ["Path" file])) + (exception: #export (cannot-modify {instant Instant} {file Path}) + (exception.report + ["Instant" (%instant instant)] + ["Path" file])) -(with-expansions [<for-jvm> (as-is (import: #long java/lang/String) + (import: #long java/lang/String) (import: #long java/io/File (new [java/lang/String]) @@ -372,7 +373,188 @@ (as-is <for-jvm>) (~~ (static @.jvm)) - (as-is <for-jvm>)}))) + (as-is <for-jvm>) + + (~~ (static @.js)) + (as-is (import: Buffer + (#static from [Binary] ..Buffer)) + + (import: NodeJsError + (code host.String)) + + (import: FileDescriptor) + + (import: Stats + (size host.Number) + (mtimeMs host.Number) + (isFile [] #try host.Boolean) + (isDirectory [] #try host.Boolean)) + + (import: FsConstants + (F_OK host.Number) + (R_OK host.Number) + (W_OK host.Number) + (X_OK host.Number)) + + (import: Fs + (constants FsConstants) + (readFileSync [host.String] #try Binary) + (appendFileSync [host.String Buffer] #try Any) + (writeFileSync [host.String Buffer] #try Any) + (statSync [host.String] #try Stats) + (accessSync [host.String host.Number] #try Any) + (renameSync [host.String host.String] #try Any) + (utimesSync [host.String host.Number host.Number] #try Any) + (unlink [host.String] #try Any) + (readdirSync [host.String] #try (Array host.String)) + (mkdirSync [host.String] #try Any) + (rmdirSync [host.String] #try Any)) + + (import: JsPath + (sep host.String)) + + (import: (#static require [host.String] Any)) + + (template: (!fs) + (:coerce ..Fs (..require "fs"))) + + (structure: (file path) + (-> Path (File IO)) + + (~~ (template [<name> <method>] + [(def: <name> + (..can-modify + (function (<name> data) + (io.io (<method> [path (Buffer::from data)] (!fs))))))] + + [over-write Fs::writeFileSync] + [append Fs::appendFileSync] + )) + + (def: content + (..can-query + (function (content _) + (io.io (Fs::readFileSync [path] (!fs)))))) + + (def: size + (..can-query + (function (size _) + (|> (Fs::statSync [path] (!fs)) + (:: error.monad map (|>> Stats::size frac-to-nat)) + io.io)))) + + (def: last-modified + (..can-query + (function (last-modified _) + (|> (Fs::statSync [path] (!fs)) + (:: error.monad map (|>> Stats::mtimeMs + frac-to-int + duration.from-millis + instant.absolute)) + io.io)))) + + (def: can-execute? + (..can-query + (function (can-execute? _) + (io.io (do error.monad + [_ (Fs::accessSync [path (|> (!fs) Fs::constants FsConstants::F_OK)] (!fs))] + (wrap (case (Fs::accessSync [path (|> (!fs) Fs::constants FsConstants::X_OK)] (!fs)) + (#error.Success _) + true + + (#error.Failure _) + false))))))) + + (def: move + (..can-open + (function (move destination) + (io.io (do error.monad + [_ (Fs::renameSync [path destination] (!fs))] + (wrap (file destination))))))) + + (def: modify + (..can-modify + (function (modify time-stamp) + (io.io (let [when (|> time-stamp instant.relative duration.to-millis int-to-frac)] + (Fs::utimesSync [path when when] (!fs))))))) + + (def: delete + (..can-delete + (function (delete _) + (io.io (Fs::unlink [path] (!fs))))))) + + (structure: (directory path) + (-> Path (Directory IO)) + + (~~ (template [<name> <method> <capability>] + [(def: <name> + (..can-query + (function (<name> _) + (io.io (let [fs (!fs)] + (do error.monad + [subs (Fs::readdirSync [path] fs) + subs (monad.map @ (function (_ sub) + (do @ + [stats (Fs::statSync [sub] fs) + verdict (<method> [] stats)] + (wrap [verdict sub]))) + (array.to-list subs))] + (wrap (|> subs + (list.filter product.left) + (list@map (|>> product.right <capability>))))))))))] + + [files Stats::isFile ..file] + [directories Stats::isDirectory directory] + )) + + (def: discard + (..can-delete + (function (discard _) + (io.io (Fs::rmdirSync [path] (!fs))))))) + + (structure: #export system (System IO) + (~~ (template [<name> <method> <capability> <exception>] + [(def: <name> + (..can-open + (function (<name> path) + (io.io (do error.monad + [stats (Fs::statSync [path] (!fs)) + verdict (<method> [] stats)] + (if verdict + (wrap (<capability> path)) + (exception.throw <exception> [path])))))))] + + [file Stats::isFile ..file ..cannot-find-file] + [directory Stats::isDirectory ..directory ..cannot-find-directory] + )) + + (~~ (template [<name> <capability> <exception> <prep>] + [(def: <name> + (..can-open + (function (<name> path) + (io.io (let [fs (!fs)] + (case (Fs::accessSync [path (|> (!fs) Fs::constants FsConstants::F_OK)] fs) + (#error.Success _) + (exception.throw <exception> [path]) + + (#error.Failure _) + (do error.monad + [_ (|> fs <prep>)] + (wrap (<capability> path)))))))))] + + [create-file ..file ..cannot-create-file (Fs::appendFileSync [path (Buffer::from (binary.create 0))])] + [create-directory ..directory ..cannot-create-directory (Fs::mkdirSync [path])] + )) + + (def: separator + (if host.on-node-js? + (|> (..require "path") + (:coerce JsPath) + JsPath::sep) + "/")) + ) + ) + }))) (template [<get> <signature> <create> <find> <exception>] [(def: #export (<get> monad system path) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux index 2775e1e51..0b3990cf0 100644 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux @@ -22,8 +22,8 @@ ["/#" // [macro (#+ Expander)] [extension - ["#." analysis - ["." jvm]]] + ["." bundle] + ["#." analysis]] ["/#" // ["#." analysis (#+ Analysis Operation)] [default @@ -45,7 +45,7 @@ (def: #export state ////analysis.State+ - [(///analysis.bundle ..eval jvm.bundle) + [(///analysis.bundle ..eval bundle.empty) (////analysis.state (init.info @.jvm) [])]) (def: #export primitive |