From a84e20e455f4d8ab86dd5a20c333bace11a56104 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 7 Aug 2020 20:56:37 -0400 Subject: Some fixes. --- stdlib/source/lux/control/concurrency/process.lux | 37 +++++--- stdlib/source/lux/control/parser/cli.lux | 3 + stdlib/source/lux/data/number/int.lux | 13 ++- stdlib/source/lux/host.js.lux | 92 +++++++++++------- stdlib/source/lux/locale.lux | 29 +++--- stdlib/source/lux/locale/language.lux | 2 +- .../language/lux/phase/analysis/inference.lux | 28 +++--- .../language/lux/phase/extension/analysis/js.lux | 23 ++++- .../lux/phase/extension/generation/js/host.lux | 32 ++++++- .../language/lux/phase/generation/js/structure.lux | 4 +- stdlib/source/lux/tool/compiler/meta/archive.lux | 4 +- stdlib/source/lux/world/file.lux | 105 ++++++++++++--------- stdlib/source/test/lux/control.lux | 2 +- 13 files changed, 238 insertions(+), 136 deletions(-) (limited to 'stdlib/source') diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux index dd38e3041..04bfbbbae 100644 --- a/stdlib/source/lux/control/concurrency/process.lux +++ b/stdlib/source/lux/control/concurrency/process.lux @@ -55,7 +55,10 @@ (host.import: #long java/util/concurrent/ScheduledThreadPoolExecutor (new [int]) - (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))))} + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) + + @.js + (as-is (host.import: (setTimeout [host.Function host.Number] Any)))} ## Default (type: Process @@ -79,16 +82,21 @@ ## Default 1)) -(def: runner - (for {@.old - (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism)) +(for {@.old + (def: runner + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))) - @.jvm - (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))} - - ## Default - (: (Atom (List Process)) - (atom.atom (list))))) + @.jvm + (def: runner + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))) + + @.js + (as-is)} + + ## Default + (def: runner + (Atom (List Process)) + (atom.atom (list)))) (def: #export (schedule milli-seconds action) (-> Nat (IO Any) (IO Any)) @@ -110,7 +118,11 @@ (case milli-seconds 0 (java/util/concurrent/Executor::execute runnable runner) _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS - runner)))} + runner))) + + @.js + (io.io (..setTimeout [(host.closure [] (io.run action)) + (n.frac milli-seconds)]))} ## Default (do io.monad @@ -124,6 +136,9 @@ (as-is) @.jvm + (as-is) + + @.js (as-is)} ## Default diff --git a/stdlib/source/lux/control/parser/cli.lux b/stdlib/source/lux/control/parser/cli.lux index 39786b94f..e4330b129 100644 --- a/stdlib/source/lux/control/parser/cli.lux +++ b/stdlib/source/lux/control/parser/cli.lux @@ -146,6 +146,9 @@ (list) @.jvm + (list) + + @.js (list)} (list g!_ (` ((~! process.run!) [])))))] diff --git a/stdlib/source/lux/data/number/int.lux b/stdlib/source/lux/data/number/int.lux index 80842692e..a5c7cbbea 100644 --- a/stdlib/source/lux/data/number/int.lux +++ b/stdlib/source/lux/data/number/int.lux @@ -14,7 +14,8 @@ [text (#+ Char)] ["." maybe]]] ["." // #_ - ["#." nat]]) + ["#." nat] + ["#." i64]]) (def: #export (= reference sample) {#.doc "Int(eger) equivalence."} @@ -150,8 +151,14 @@ (Interval Int) (def: &enum ..enum) - (def: top +9,223,372,036,854,775,807) - (def: bottom -9,223,372,036,854,775,808)) + (def: top + ## +9,223,372,036,854,775,807 + (let [half (//i64.left-shift 62 +1)] + (+ half + (dec half)))) + (def: bottom + ## -9,223,372,036,854,775,808 + (//i64.left-shift 63 +1))) (template [ ] [(structure: #export diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 8dd6f1ad8..3f43b8948 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -12,7 +12,7 @@ ["." text ["%" format (#+ format)]] [collection - ["." list ("#@." functor)]]] + ["." list ("#@." functor fold)]]] [type abstract] ["." macro (#+ with-gensyms) @@ -260,45 +260,69 @@ 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)) +(template: #export (type-of object) + ("js type-of" object)) + +(syntax: #export (constant type + {[head tail] (.tuple (<>.and .local-identifier (<>.some .local-identifier)))}) + (with-gensyms [g!_] + (let [constant (` ("js constant" (~ (code.text head))))] + (case tail + #.Nil + (wrap (list (` (: (.Maybe (~ type)) + (case (..type-of (~ constant)) + "undefined" + #.None + + (~ g!_) + (#.Some (:coerce (~ type) (~ constant)))))))) + + (#.Cons [next tail]) + (let [separator "."] + (wrap (list (` (: (.Maybe (~ type)) + (case (..type-of (~ constant)) + "undefined" + #.None + + (~ g!_) + (..constant (~ type) [(~ (code.local-identifier (format head "." next))) + (~+ (list@map code.local-identifier tail))]))))))))))) + +(template: (!defined? ) + (.case (..constant Any ) + #.None + .false + + (#.Some _) + .true)) + +(template [ ] + [(def: #export + Bit + (!defined? ))] + + [on-browser? [window]] + [on-nashorn? [java lang Object]] + ) (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"))) + (case (..constant (Object Any) [process]) + (#.Some process) + (case (:coerce Text + ("js apply" ("js constant" "Object.prototype.toString.call") process)) "[object process]" true _ - false))) - -(template: (!defined? constant) - (case (..type-of ("js constant" constant)) - "undefined" - false + false) - _ - true)) + #.None + false)) -(def: #export on-nashorn? - Bit - (and (!defined? "java") - (!defined? "java.lang") - (!defined? "java.lang.Object"))) +(template: #export (closure ) + (.:coerce ..Function + (`` ("js function" + (~~ (template.count )) + (.function (_ []) + ))))) diff --git a/stdlib/source/lux/locale.lux b/stdlib/source/lux/locale.lux index d4bcb2c94..69920aba9 100644 --- a/stdlib/source/lux/locale.lux +++ b/stdlib/source/lux/locale.lux @@ -4,6 +4,7 @@ [equivalence (#+ Equivalence)] [hash (#+ Hash)]] [data + ["." maybe ("#@." functor)] ["." text ["%" format (#+ format)] ["." encoding (#+ Encoding)]]] @@ -24,29 +25,27 @@ (def: #export (locale language territory encoding) (-> Language (Maybe Territory) (Maybe Encoding) Locale) - (:abstraction (format (language.language language) - (case territory - (#.Some territory) - (format ..territory-separator (territory.long-code territory)) - - #.None - "") - (case encoding - (#.Some encoding) - (format ..encoding-separator (encoding.name encoding)) - - #.None - "")))) + (:abstraction (format (language.code language) + (|> territory + (maybe@map (|>> territory.long-code (format ..territory-separator))) + (maybe.default "")) + (|> encoding + (maybe@map (|>> encoding.name (format ..encoding-separator))) + (maybe.default ""))))) (def: #export code (-> Locale Text) (|>> :representation)) - (structure: #export equivalence (Equivalence Locale) + (structure: #export equivalence + (Equivalence Locale) + (def: (= reference sample) (:: text.equivalence = (:representation reference) (:representation sample)))) - (structure: #export hash (Hash Locale) + (structure: #export hash + (Hash Locale) + (def: &equivalence ..equivalence) (def: hash diff --git a/stdlib/source/lux/locale/language.lux b/stdlib/source/lux/locale/language.lux index dbda89f73..1b09d4ddf 100644 --- a/stdlib/source/lux/locale/language.lux +++ b/stdlib/source/lux/locale/language.lux @@ -16,7 +16,7 @@ Text - (def: #export language + (def: #export code (-> Language Text) (|>> :representation)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux index f4bae0122..38f1d3bd3 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux @@ -3,7 +3,7 @@ [abstract [monad (#+ do)]] [control - ["ex" exception (#+ exception:)]] + ["." exception (#+ exception:)]] [data ["." maybe] [number @@ -27,25 +27,25 @@ [archive (#+ Archive)]]]]]]) (exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type}) - (ex.report ["Tag" (%.nat tag)] - ["Variant size" (%.int (.int size))] - ["Variant type" (%.type type)])) + (exception.report + ["Tag" (%.nat tag)] + ["Variant size" (%.int (.int size))] + ["Variant type" (%.type type)])) (exception: #export (cannot-infer {type Type} {args (List Code)}) - (ex.report ["Type" (%.type type)] - ["Arguments" (|> args - list.enumerate - (list@map (function (_ [idx argC]) - (format text.new-line " " (%.nat idx) " " (%.code argC)))) - (text.join-with ""))])) + (exception.report + ["Type" (%.type type)] + ["Arguments" (exception.enumerate %.code args)])) (exception: #export (cannot-infer-argument {inferred Type} {argument Code}) - (ex.report ["Inferred Type" (%.type inferred)] - ["Argument" (%.code argument)])) + (exception.report + ["Inferred Type" (%.type inferred)] + ["Argument" (%.code argument)])) (exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat}) - (ex.report ["Expected" (%.int (.int expected))] - ["Actual" (%.int (.int actual))])) + (exception.report + ["Expected" (%.int (.int expected))] + ["Actual" (%.int (.int actual))])) (template [] [(exception: #export ( {type Type}) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux index 4ec689361..b195a11a2 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux @@ -1,5 +1,6 @@ (.module: [lux #* + ["." host] [abstract ["." monad (#+ do)]] [control @@ -8,10 +9,11 @@ [data [collection ["." array (#+ Array)] - ["." dictionary]]] - [type + ["." dictionary] + ["." list]]] + [type (#+ tuple) ["." check]] - [target + ["@" target ["_" js]]] [// ["/" lux (#+ custom)] @@ -187,6 +189,20 @@ _ (type.infer .Text)] (wrap (#analysis.Extension extension (list objectA)))))])) +(def: js::function + Handler + (custom + [($_ <>.and .nat .any) + (function (_ extension phase archive [arity abstractionC]) + (do phase.monad + [#let [inputT (tuple (list.repeat arity Any))] + abstractionA (type.with-type (-> inputT Any) + (phase archive abstractionC)) + _ (type.infer (for {@.js host.Function} + Any))] + (wrap (#analysis.Extension extension (list (analysis.nat arity) + abstractionA)))))])) + (def: #export bundle Bundle (<| (bundle.prefix "js") @@ -194,6 +210,7 @@ (bundle.install "constant" js::constant) (bundle.install "apply" js::apply) (bundle.install "type-of" js::type-of) + (bundle.install "function" js::function) (dictionary.merge bundle::array) (dictionary.merge bundle::object) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux index 514df447c..d9b52e450 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux @@ -8,9 +8,10 @@ ["" synthesis (#+ Parser)]]] [data [collection - ["." dictionary]]] + ["." dictionary] + ["." list]]] [target - ["_" js (#+ Expression)]]] + ["_" js (#+ Var Expression)]]] ["." // #_ ["#." common (#+ custom)] ["//#" /// #_ @@ -23,8 +24,10 @@ ["//" js #_ ["#." runtime (#+ Operation Phase Handler Bundle with-vars)]]] - ["///#" //// #_ - ["#." phase]]]]]) + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) (def: array::new (Unary Expression) @@ -124,6 +127,26 @@ inputsG (monad.map @ (phase archive) inputsS)] (wrap (_.apply/* abstractionG inputsG))))])) +(def: js::function + (custom + [($_ <>.and .i64 .any) + (function (_ extension phase archive [arity abstractionS]) + (do {@ ////////phase.monad} + [abstractionG (phase archive abstractionS) + #let [variable (: (-> Text (Operation Var)) + (|>> generation.gensym + (:: @ map _.var)))] + g!inputs (monad.map @ (function (_ _) (variable "input")) + (list.repeat (.nat arity) [])) + g!abstraction (variable "abstraction")] + (wrap (_.closure g!inputs + ($_ _.then + (_.define g!abstraction abstractionG) + (_.return (case (.nat arity) + 0 (_.apply/1 g!abstraction //runtime.unit) + 1 (_.apply/* g!abstraction g!inputs) + _ (_.apply/1 g!abstraction (_.array g!inputs)))))))))])) + (def: #export bundle Bundle (<| (/.prefix "js") @@ -131,6 +154,7 @@ (/.install "constant" js::constant) (/.install "apply" js::apply) (/.install "type-of" (unary _.type-of)) + (/.install "function" js::function) (dictionary.merge ..array) (dictionary.merge ..object) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux index 07fc172a6..dee0aa051 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux @@ -13,13 +13,11 @@ ["//#" /// ["#." phase ("#@." monad)]]]]) -(def: unit Expression (//primitive.text /////synthesis.unit)) - (def: #export (tuple generate archive elemsS+) (Generator (Tuple Synthesis)) (case elemsS+ #.Nil - (///////phase@wrap ..unit) + (///////phase@wrap //runtime.unit) (#.Cons singletonS #.Nil) (generate archive singletonS) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index 1aea7327f..ffd6e65ea 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -24,9 +24,7 @@ ["." dictionary (#+ Dictionary)] ["." set]]] [type - abstract] - [world - [file (#+ File)]]] + abstract]] [/ ["." signature (#+ Signature)] ["." key (#+ Key)] diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 3a976918f..2d41f7d75 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -453,10 +453,33 @@ (sep host.String) (basename [host.String] host.String)) - (import: (require [host.String] Any)) - - (template: (!fs) - (:coerce ..Fs (..require "fs"))) + (template [ ] + [(def: + (host.constant (-> host.String Any) ))] + + [normal-require [require]] + [global-require [global require]] + [process-load [global process mainModule constructor _load]] + ) + + (def: require + (-> host.String Any) + (case [normal-require global-require process-load] + (^or [(#.Some require) _ _] + [_ (#.Some require) _] + [_ _ (#.Some require)]) + require + + _ + (undefined))) + + (template [ ] + [(def: + (:coerce (..require )))] + + [node-fs "fs" ..Fs] + [node-path "path" ..JsPath] + ) (`` (structure: (file path) (-> Path (File IO)) @@ -465,7 +488,7 @@ [(def: (..can-modify (function ( data) - (io.io ( [path (Buffer::from data)] (!fs))))))] + (io.io ( [path (Buffer::from data)] ..node-fs)))))] [over-write Fs::writeFileSync] [append Fs::appendFileSync] @@ -473,15 +496,13 @@ (def: content (..can-query - (function (content _) - (io.io (Fs::readFileSync [path] (!fs)))))) + (function (_ _) + (io.io (Fs::readFileSync [path] ..node-fs))))) (def: name (..can-see - (function (name _) - (|> (..require "path") - (:coerce JsPath) - (JsPath::basename path))))) + (function (_ _) + (JsPath::basename path ..node-path)))) (def: path (..can-see @@ -491,14 +512,14 @@ (def: size (..can-query (function (size _) - (|> (Fs::statSync [path] (!fs)) + (|> (Fs::statSync [path] ..node-fs) (:: try.monad map (|>> Stats::size f.nat)) io.io)))) (def: last-modified (..can-query (function (last-modified _) - (|> (Fs::statSync [path] (!fs)) + (|> (Fs::statSync [path] ..node-fs) (:: try.monad map (|>> Stats::mtimeMs f.int duration.from-millis @@ -509,8 +530,8 @@ (..can-query (function (can-execute? _) (io.io (do try.monad - [_ (Fs::accessSync [path (|> (!fs) Fs::constants FsConstants::F_OK)] (!fs))] - (wrap (case (Fs::accessSync [path (|> (!fs) Fs::constants FsConstants::X_OK)] (!fs)) + [_ (Fs::accessSync [path (|> ..node-fs Fs::constants FsConstants::F_OK)] ..node-fs)] + (wrap (case (Fs::accessSync [path (|> ..node-fs Fs::constants FsConstants::X_OK)] ..node-fs) (#try.Success _) true @@ -521,19 +542,19 @@ (..can-open (function (move destination) (io.io (do try.monad - [_ (Fs::renameSync [path destination] (!fs))] + [_ (Fs::renameSync [path destination] ..node-fs)] (wrap (file destination))))))) (def: modify (..can-modify (function (modify time-stamp) (io.io (let [when (|> time-stamp instant.relative duration.to-millis i.frac)] - (Fs::utimesSync [path when when] (!fs))))))) + (Fs::utimesSync [path when when] ..node-fs)))))) (def: delete (..can-delete (function (delete _) - (io.io (Fs::unlink [path] (!fs)))))))) + (io.io (Fs::unlink [path] ..node-fs))))))) (`` (structure: (directory path) (-> Path (Directory IO)) @@ -542,18 +563,17 @@ [(def: (..can-query (function ( _) - (io.io (let [fs (!fs)] - (do {@ try.monad} - [subs (Fs::readdirSync [path] fs) - subs (monad.map @ (function (_ sub) - (do @ - [stats (Fs::statSync [sub] fs) - verdict ( [] stats)] - (wrap [verdict sub]))) - (array.to-list subs))] - (wrap (|> subs - (list.filter product.left) - (list@map (|>> product.right ))))))))))] + (io.io (do {@ try.monad} + [subs (Fs::readdirSync [path] ..node-fs) + subs (monad.map @ (function (_ sub) + (do @ + [stats (Fs::statSync [sub] ..node-fs) + verdict ( [] stats)] + (wrap [verdict sub]))) + (array.to-list subs))] + (wrap (|> subs + (list.filter product.left) + (list@map (|>> product.right )))))))))] [files Stats::isFile ..file] [directories Stats::isDirectory directory] @@ -562,7 +582,7 @@ (def: discard (..can-delete (function (discard _) - (io.io (Fs::rmdirSync [path] (!fs)))))))) + (io.io (Fs::rmdirSync [path] ..node-fs))))))) (`` (structure: #export system (System IO) @@ -572,7 +592,7 @@ (..can-open (function ( path) (io.io (do try.monad - [stats (Fs::statSync [path] (!fs)) + [stats (Fs::statSync [path] ..node-fs) verdict ( [] stats)] (if verdict (wrap ( path)) @@ -586,15 +606,14 @@ [(def: (..can-open (function ( path) - (io.io (let [fs (!fs)] - (case (Fs::accessSync [path (|> (!fs) Fs::constants FsConstants::F_OK)] fs) - (#try.Success _) - (exception.throw [path]) - - (#try.Failure _) - (do try.monad - [_ (|> fs )] - (wrap ( path)))))))))] + (io.io (case (Fs::accessSync [path (|> ..node-fs Fs::constants FsConstants::F_OK)] ..node-fs) + (#try.Success _) + (exception.throw [path]) + + (#try.Failure _) + (do try.monad + [_ (|> ..node-fs )] + (wrap ( path))))))))] [create-file ..file ..cannot-create-file (Fs::appendFileSync [path (Buffer::from (binary.create 0))])] [create-directory ..directory ..cannot-create-directory (Fs::mkdirSync [path])] @@ -602,9 +621,7 @@ (def: separator (if host.on-node-js? - (|> (..require "path") - (:coerce JsPath) - JsPath::sep) + (JsPath::sep ..node-path) "/")) )) ) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index c0c673009..f51e07767 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -17,7 +17,6 @@ ["#/." contract] ["#/." memo] ["#/." mixin]] - ["#." try] ["#." io] ["#." parser ["#/." analysis] @@ -35,6 +34,7 @@ ["#." policy]] ["#." state] ["#." thread] + ["#." try] ["#." writer]]) (def: concurrency -- cgit v1.2.3