diff options
Diffstat (limited to 'stdlib/source/library/lux/world/program.lux')
| -rw-r--r-- | stdlib/source/library/lux/world/program.lux | 451 |
1 files changed, 451 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/world/program.lux b/stdlib/source/library/lux/world/program.lux new file mode 100644 index 000000000..8c8a0ac05 --- /dev/null +++ b/stdlib/source/library/lux/world/program.lux @@ -0,0 +1,451 @@ +(.module: + [library + [lux #* + ["@" target] + ["." ffi (#+ import:)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." function] + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [concurrency + ["." atom] + ["." promise (#+ Promise)]] + [parser + ["." environment (#+ Environment)]]] + [data + ["." bit ("#\." equivalence)] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." array (#+ Array)] + ["." dictionary (#+ Dictionary)] + ["." list ("#\." functor)]]] + ["." macro + ["." template]] + [math + [number + ["i" int]]] + [type + abstract]]] + [// + [file (#+ Path)] + [shell (#+ Exit)]]) + +(exception: #export (unknown_environment_variable {name Text}) + (exception.report + ["Name" (%.text name)])) + +(interface: #export (Program !) + (: (-> Any (! (List Text))) + available_variables) + (: (-> Text (! (Try Text))) + variable) + (: Path + home) + (: Path + directory) + (: (-> Exit (! Nothing)) + exit)) + +(def: #export (environment monad program) + (All [!] (-> (Monad !) (Program !) (! Environment))) + (do {! monad} + [variables (\ program available_variables []) + entries (monad.map ! (function (_ name) + (\ ! map (|>> [name]) (\ program variable name))) + variables)] + (wrap (|> entries + (list.all (function (_ [name value]) + (case value + (#try.Success value) + (#.Some [name value]) + + (#try.Failure _) + #.None))) + (dictionary.from_list text.hash))))) + +(`` (implementation: #export (async program) + (-> (Program IO) (Program Promise)) + + (~~ (template [<method>] + [(def: <method> + (\ program <method>))] + + [home] + [directory] + )) + + (~~ (template [<method>] + [(def: <method> + (|>> (\ program <method>) promise.future))] + + [available_variables] + [variable] + [exit] + )))) + +(def: #export (mock environment home directory) + (-> Environment Path Path (Program IO)) + (let [@dead? (atom.atom false)] + (implementation + (def: available_variables + (function.constant (io.io (dictionary.keys environment)))) + (def: (variable name) + (io.io (case (dictionary.get name environment) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name])))) + (def: home + home) + (def: directory + directory) + (def: (exit code) + (io.io (error! (%.int code))))))) + +## Do not trust the values of environment variables +## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables + +(with_expansions [<jvm> (as_is (import: java/lang/String) + + (import: (java/util/Iterator a) + ["#::." + (hasNext [] boolean) + (next [] a)]) + + (import: (java/util/Set a) + ["#::." + (iterator [] (java/util/Iterator a))]) + + (import: (java/util/Map k v) + ["#::." + (keySet [] (java/util/Set k))]) + + (import: java/lang/System + ["#::." + (#static getenv [] (java/util/Map java/lang/String java/lang/String)) + (#static getenv #as resolveEnv [java/lang/String] #io #? java/lang/String) + (#static getProperty [java/lang/String] #? java/lang/String) + (#static exit [int] #io void)]) + + (def: (jvm\\consume iterator) + (All [a] (-> (java/util/Iterator a) (List a))) + (if (java/util/Iterator::hasNext iterator) + (#.Cons (java/util/Iterator::next iterator) + (jvm\\consume iterator)) + #.Nil)) + )] + (for {@.old (as_is <jvm>) + @.jvm (as_is <jvm>) + @.js (as_is (def: default_exit! + (-> Exit (IO Nothing)) + (|>> %.int error! io.io)) + + (import: NodeJs_Process + ["#::." + (exit [ffi.Number] #io Nothing) + (cwd [] #io Path)]) + + (def: (exit_node_js! code) + (-> Exit (IO Nothing)) + (case (ffi.constant ..NodeJs_Process [process]) + (#.Some process) + (NodeJs_Process::exit (i.frac code) process) + + #.None + (..default_exit! code))) + + (import: Browser_Window + ["#::." + (close [] Nothing)]) + + (import: Browser_Location + ["#::." + (reload [] Nothing)]) + + (def: (exit_browser! code) + (-> Exit (IO Nothing)) + (case [(ffi.constant ..Browser_Window [window]) + (ffi.constant ..Browser_Location [location])] + [(#.Some window) (#.Some location)] + (exec + (Browser_Window::close [] window) + (Browser_Location::reload [] location) + (..default_exit! code)) + + [(#.Some window) #.None] + (exec + (Browser_Window::close [] window) + (..default_exit! code)) + + [#.None (#.Some location)] + (exec + (Browser_Location::reload [] location) + (..default_exit! code)) + + [#.None #.None] + (..default_exit! code))) + + (import: Object + ["#::." + (#static entries [Object] (Array (Array ffi.String)))]) + + (import: NodeJs_OS + ["#::." + (homedir [] #io Path)]) + + (template [<name> <path>] + [(def: (<name> _) + (-> [] (Maybe (-> ffi.String Any))) + (ffi.constant (-> ffi.String Any) <path>))] + + [normal_require [require]] + [global_require [global require]] + [process_load [global process mainModule constructor _load]] + ) + + (def: (require _) + (-> [] (-> ffi.String Any)) + (case [(normal_require []) (global_require []) (process_load [])] + (^or [(#.Some require) _ _] + [_ (#.Some require) _] + [_ _ (#.Some require)]) + require + + _ + (undefined)))) + @.python (as_is (import: os + ["#::." + (#static getcwd [] #io ffi.String) + (#static _exit [ffi.Integer] #io Nothing)]) + + (import: os/path + ["#::." + (#static expanduser [ffi.String] #io ffi.String)]) + + (import: os/environ + ["#::." + (#static keys [] #io (Array ffi.String)) + (#static get [ffi.String] #io #? ffi.String)])) + @.lua (as_is (ffi.import: LuaFile + ["#::." + (read [ffi.String] #io #? ffi.String) + (close [] #io ffi.Boolean)]) + + (ffi.import: (io/popen [ffi.String] #io #try #? LuaFile)) + (ffi.import: (os/getenv [ffi.String] #io #? ffi.String)) + (ffi.import: (os/exit [ffi.Integer] #io Nothing)) + + (def: (run_command default command) + (-> Text Text (IO Text)) + (do {! io.monad} + [outcome (io/popen [command])] + (case outcome + (#try.Success outcome) + (case outcome + (#.Some file) + (do ! + [?output (LuaFile::read ["*l"] file) + _ (LuaFile::close [] file)] + (wrap (maybe.default default ?output))) + + #.None + (wrap default)) + + (#try.Failure _) + (wrap default))))) + @.ruby (as_is (ffi.import: Env #as RubyEnv + ["#::." + (#static keys [] (Array Text)) + (#static fetch [Text] #io #? Text)]) + + (ffi.import: "fileutils" FileUtils #as RubyFileUtils + ["#::." + (#static pwd Path)]) + + (ffi.import: Dir #as RubyDir + ["#::." + (#static home Path)]) + + (ffi.import: Kernel #as RubyKernel + ["#::." + (#static exit [Int] #io Nothing)])) + + ## @.php + ## (as_is (ffi.import: (exit [Int] #io Nothing)) + ## ## https://www.php.net/manual/en/function.exit.php + ## (ffi.import: (getcwd [] #io ffi.String)) + ## ## https://www.php.net/manual/en/function.getcwd.php + ## (ffi.import: (getenv #as getenv/1 [ffi.String] #io ffi.String)) + ## (ffi.import: (getenv #as getenv/0 [] #io (Array ffi.String))) + ## ## https://www.php.net/manual/en/function.getenv.php + ## ## https://www.php.net/manual/en/function.array-keys.php + ## (ffi.import: (array_keys [(Array ffi.String)] (Array ffi.String))) + ## ) + + ## @.scheme + ## (as_is (ffi.import: (exit [Int] #io Nothing)) + ## ## https://srfi.schemers.org/srfi-98/srfi-98.html + ## (abstract: Pair Any) + ## (abstract: PList Any) + ## (ffi.import: (get-environment-variables [] #io PList)) + ## (ffi.import: (car [Pair] Text)) + ## (ffi.import: (cdr [Pair] Text)) + ## (ffi.import: (car #as head [PList] Pair)) + ## (ffi.import: (cdr #as tail [PList] PList))) + } + (as_is))) + +(implementation: #export default + (Program IO) + + (def: (available_variables _) + (with_expansions [<jvm> (io.io (|> (java/lang/System::getenv) + java/util/Map::keySet + java/util/Set::iterator + ..jvm\\consume))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (io.io (if ffi.on_node_js? + (case (ffi.constant Object [process env]) + (#.Some process/env) + (|> (Object::entries [process/env]) + array.to_list + (list\map (|>> (array.read 0) maybe.assume))) + + #.None + (list)) + (list))) + @.python (\ io.monad map array.to_list (os/environ::keys [])) + ## Lua offers no way to get all the environment variables available. + @.lua (io.io (list)) + @.ruby (|> (RubyEnv::keys []) + array.to_list + io.io) + ## @.php (do io.monad + ## [environment (..getenv/0 [])] + ## (wrap (|> environment + ## ..array_keys + ## array.to_list + ## (list\map (function (_ variable) + ## [variable ("php array read" (:as Nat variable) environment)])) + ## (dictionary.from_list text.hash)))) + ## @.scheme (do io.monad + ## [input (..get-environment-variables [])] + ## (loop [input input + ## output environment.empty] + ## (if ("scheme object nil?" input) + ## (wrap output) + ## (let [entry (..head input)] + ## (recur (..tail input) + ## (dictionary.put (..car entry) (..cdr entry) output)))))) + }))) + + (def: (variable name) + (template.let [(!fetch <method>) + [(do io.monad + [value (<method> name)] + (wrap (case value + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name]))))]] + (with_expansions [<jvm> (!fetch java/lang/System::resolveEnv)] + (for {@.old <jvm> + @.jvm <jvm> + @.js (io.io (if ffi.on_node_js? + (case (do maybe.monad + [process/env (ffi.constant Object [process env])] + (array.read (:as Nat name) + (:as (Array Text) process/env))) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name])) + (exception.throw ..unknown_environment_variable [name]))) + @.python (!fetch os/environ::get) + @.lua (!fetch os/getenv) + @.ruby (!fetch RubyEnv::fetch) + })))) + + (def: home + (io.run + (with_expansions [<default> (io.io "~") + <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.home")))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (if ffi.on_node_js? + (|> (..require [] "os") + (:as NodeJs_OS) + (NodeJs_OS::homedir [])) + <default>) + @.python (os/path::expanduser ["~"]) + @.lua (..run_command "~" "echo ~") + @.ruby (io.io (RubyDir::home)) + ## @.php (do io.monad + ## [output (..getenv/1 ["HOME"])] + ## (wrap (if (bit\= false (:as Bit output)) + ## "~" + ## output))) + } + ## TODO: Replace dummy implementation. + <default>)))) + + (def: directory + (io.run + (with_expansions [<default> "." + <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.dir")))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (if ffi.on_node_js? + (case (ffi.constant ..NodeJs_Process [process]) + (#.Some process) + (NodeJs_Process::cwd [] process) + + #.None + (io.io <default>)) + (io.io <default>)) + @.python (os::getcwd []) + @.lua (do io.monad + [#let [default <default>] + on_windows (..run_command default "cd")] + (if (is? default on_windows) + (..run_command default "pwd") + (wrap on_windows))) + @.ruby (io.io (RubyFileUtils::pwd)) + ## @.php (do io.monad + ## [output (..getcwd [])] + ## (wrap (if (bit\= false (:as Bit output)) + ## "." + ## output))) + } + ## TODO: Replace dummy implementation. + (io.io <default>))))) + + (def: (exit code) + (with_expansions [<jvm> (do io.monad + [_ (java/lang/System::exit code)] + (wrap (undefined)))] + (for {@.old <jvm> + @.jvm <jvm> + @.js (cond ffi.on_node_js? + (..exit_node_js! code) + + ffi.on_browser? + (..exit_browser! code) + + ## else + (..default_exit! code)) + @.python (os::_exit [code]) + @.lua (os/exit [code]) + @.ruby (RubyKernel::exit [code]) + ## @.php (..exit [code]) + ## @.scheme (..exit [code]) + })))) |