/* Copyright (c) 2016 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Author: Leonardo de Moura */ #include #include #include #include #include #ifdef _MSC_VER #include #define getcwd _getcwd #define PATH_MAX _MAX_PATH #else #include #endif #ifdef __linux__ #include #endif #include #include "runtime/sstream.h" #include "library/handle.h" #include "library/io_state.h" #include "library/constants.h" #include "library/process.h" #include "library/tactic/tactic_state.h" #include "library/vm/vm.h" #include "library/vm/vm_array.h" #include "library/vm/vm_string.h" #include "library/vm/vm_nat.h" #include "library/vm/vm_option.h" #include "library/vm/vm_io.h" #include "library/vm/vm_list.h" namespace lean { vm_obj io_core(vm_obj const &, vm_obj const &) { return mk_vm_unit(); } vm_obj mk_io_result(vm_obj const & r) { return mk_vm_constructor(0, 1, &r); } vm_obj mk_io_failure(vm_obj const & e) { return mk_vm_constructor(1, 1, &e); } vm_obj mk_io_failure(std::string const & s) { return mk_io_failure(mk_vm_constructor(0, to_obj(s))); } vm_obj mk_io_failure(sstream const & s) { return mk_io_failure(mk_vm_constructor(0, to_obj(s.str()))); } static vm_obj io_put_str(vm_obj const & str, vm_obj const &) { get_global_ios().get_regular_stream() << to_string(str); return mk_io_result(mk_vm_unit()); } static vm_obj io_get_line(vm_obj const &) { if (get_global_ios().get_options().get_bool("server")) throw exception("get_line: cannot read from stdin in server mode"); std::string str; std::getline(std::cin, str); return mk_io_result(to_obj(str)); } static vm_obj cmdline_args_to_obj(std::vector const & ss) { buffer objs; for (auto & s : ss) objs.push_back(to_obj(s)); return to_obj(objs); } struct vm_handle : public vm_external { handle_ref m_handle; vm_handle(handle_ref const & h):m_handle(h) {} vm_handle(handle_ref && h):m_handle(std::move(h)) {} virtual ~vm_handle() {} virtual void dealloc() override { delete this; } virtual vm_external * clone(vm_clone_fn const &) override { return new vm_handle(m_handle); } virtual vm_external * ts_clone(vm_clone_fn const &) override { lean_unreachable(); } }; static handle_ref const & to_handle(vm_obj const & o) { lean_vm_check(dynamic_cast(to_external(o))); return static_cast(to_external(o))->m_handle; } static vm_obj to_obj(handle_ref && h) { return mk_vm_external(new vm_handle(std::move(h))); } struct vm_child : public vm_external { std::shared_ptr m_child; vm_child(std::shared_ptr && h):m_child(std::move(h)) {} vm_child(std::shared_ptr const & h):m_child(h) {} virtual ~vm_child() {} virtual void dealloc() override { delete this; } virtual vm_external * clone(vm_clone_fn const &) override { return new vm_child(m_child); } virtual vm_external * ts_clone(vm_clone_fn const &) override { lean_unreachable(); } }; std::shared_ptr const & to_child(vm_obj const & o) { lean_vm_check(dynamic_cast(to_external(o))); return static_cast(to_external(o))->m_child; } static vm_obj to_obj(std::shared_ptr && h) { return mk_vm_external(new vm_child(std::move(h))); } /* inductive io.mode | read | write | read_write | append */ char const * to_c_io_mode(vm_obj const & mode, vm_obj const & bin) { bool is_bin = to_bool(bin); switch (cidx(mode)) { case 0: return is_bin ? "rb" : "r"; case 1: return is_bin ? "wb" : "w"; case 2: return is_bin ? "r+b" : "r+"; case 3: return is_bin ? "ab" : "a"; } lean_vm_check(false); lean_unreachable(); } /* (mk_file_handle : string → io.mode → bool → m io.error handle) */ static vm_obj fs_mk_file_handle(vm_obj const & fname, vm_obj const & m, vm_obj const & bin, vm_obj const &) { FILE * h = fopen(to_string(fname).c_str(), to_c_io_mode(m, bin)); if (h != nullptr) return mk_io_result(to_obj(std::make_shared(h))); else return mk_io_failure(sstream() << "failed to open file '" << to_string(fname) << "'"); } static vm_obj mk_handle_has_been_closed_error() { return mk_io_failure("invalid io action, handle has been closed"); } static vm_obj fs_is_eof(vm_obj const & h, vm_obj const &) { handle_ref const & href = to_handle(h); if (href->is_closed()) return mk_handle_has_been_closed_error(); bool r = feof(href->m_file) != 0; return mk_io_result(mk_vm_bool(r)); } static vm_obj fs_flush(vm_obj const & h, vm_obj const &) { handle_ref const & href = to_handle(h); if (href->is_closed()) { return mk_handle_has_been_closed_error(); } try { href->flush(); return mk_io_result(mk_vm_unit()); } catch (handle_exception e) { return mk_io_failure("flush failed"); } } static vm_obj fs_close(vm_obj const & h, vm_obj const &) { handle_ref const & href = to_handle(h); if (href->is_closed()) { return mk_handle_has_been_closed_error(); } if (href->is_stdin()) return mk_io_failure("close failed, stdin cannot be closed"); if (href->is_stdout()) return mk_io_failure("close failed, stdout cannot be closed"); if (href->is_stderr()) return mk_io_failure("close failed, stderr cannot be closed"); try { href->close(); return mk_io_result(mk_vm_unit()); } catch (handle_exception e) { return mk_io_failure("close failed"); } } static vm_obj fs_read(vm_obj const & h, vm_obj const & n, vm_obj const &) { handle_ref const & href = to_handle(h); if (href->is_closed()) return mk_handle_has_been_closed_error(); buffer tmp; unsigned num = force_to_unsigned(n); /* TODO(Leo): handle size_t */ tmp.resize(num, 0); size_t sz = fread(tmp.data(), 1, num, href->m_file); if (ferror(href->m_file)) { clearerr(href->m_file); return mk_io_failure("read failed"); } return mk_io_result(to_obj(std::string(tmp.data(), sz))); } static vm_obj fs_write(vm_obj const & h, vm_obj const & b, vm_obj const &) { handle_ref const & href = to_handle(h); if (href->is_closed()) { return mk_handle_has_been_closed_error(); } try { href->write(to_string(b)); return mk_io_result(mk_vm_unit()); } catch (handle_exception e) { return mk_io_failure("write failed"); } } static vm_obj fs_get_line(vm_obj const & h, vm_obj const &) { handle_ref const & href = to_handle(h); if (href->is_closed()) { return mk_handle_has_been_closed_error(); } std::string r; while (true) { int c = fgetc(href->m_file); if (ferror(href->m_file)) { clearerr(href->m_file); return mk_io_failure("get_line failed"); } if (c == EOF) break; r.push_back(static_cast(c)); if (c == '\n') break; } return mk_io_result(to_obj(r)); } static vm_obj fs_stdin(vm_obj const &) { return mk_io_result(to_obj(std::make_shared(stdin))); } static vm_obj fs_stdout(vm_obj const &) { return mk_io_result(to_obj(std::make_shared(stdout))); } static vm_obj fs_stderr(vm_obj const &) { return mk_io_result(to_obj(std::make_shared(stderr))); } /* class monad_io_file_system (m : Type → Type → Type) [monad_io m] := /- Remark: in Haskell, they also provide (Maybe TextEncoding) and NewlineMode -/ (mk_file_handle : string → io.mode → bool → m io.error (handle m)) (is_eof : (handle m) → m io.error bool) (flush : (handle m) → m io.error unit) (close : (handle m) → m io.error unit) (read : (handle m) → nat → m io.error string) (write : (handle m) → string → m io.error unit) (get_line : (handle m) → m io.error string) (stdin : m io.error (handle m)) (stdout : m io.error (handle m)) (stderr : m io.error (handle m)) */ static vm_obj monad_io_file_system_impl () { return mk_vm_constructor(0, { mk_native_closure(fs_mk_file_handle), mk_native_closure(fs_is_eof), mk_native_closure(fs_flush), mk_native_closure(fs_close), mk_native_closure(fs_read), mk_native_closure(fs_write), mk_native_closure(fs_get_line), mk_native_closure(fs_stdin), mk_native_closure(fs_stdout), mk_native_closure(fs_stderr)}); } stdio to_stdio(vm_obj const & o) { switch (cidx(o)) { case 0: return stdio::PIPED; case 1: return stdio::INHERIT; case 2: return stdio::NUL; default: lean_unreachable() } } /* structure spawn_args := (cmd : string) /- Add an argument to pass to the process. -/ (args : list string) /- Configuration for the process's stdin handle. -/ (stdin := stdio.inherit) /- Configuration for the process's stdout handle. -/ (stdout := stdio.inherit) /- Configuration for the process's stderr handle. -/ (stderr := stdio.inherit) (cwd : option string) (env : list (string × option string)) */ static vm_obj io_process_spawn(vm_obj const & process_obj, vm_obj const &) { std::string cmd = to_string(cfield(process_obj, 0)); list args = to_list(cfield(process_obj, 1), [&] (vm_obj const & o) -> std::string { return to_string(o); }); auto stdin_stdio = to_stdio(cfield(process_obj, 2)); auto stdout_stdio = to_stdio(cfield(process_obj, 3)); auto stderr_stdio = to_stdio(cfield(process_obj, 4)); optional cwd; if (!is_none(cfield(process_obj, 5))) cwd = to_string(get_some_value(cfield(process_obj, 5))); lean::process proc(cmd, stdin_stdio, stdout_stdio, stderr_stdio); for (auto arg : args) { proc.arg(arg); } to_list(cfield(process_obj, 6), [&] (vm_obj const & o) { auto k = to_string(cfield(o, 0)); optional v; if (!is_none(cfield(o, 1))) v = to_string(get_some_value(cfield(o, 1))); proc.set_env(k, v); return unit(); }); if (cwd) proc.set_cwd(*cwd); return mk_io_result(to_obj(proc.spawn())); } static vm_obj io_process_wait(vm_obj const & ch, vm_obj const &) { return mk_io_result(mk_vm_nat(to_child(ch)->wait())); } /* class monad_io_process (m : Type → Type → Type) [monad_io m] := (child : Type) (stdin : child → (handle m)) (stdout : child → (handle m)) (stderr : child → (handle m)) (spawn : io.process.spawn_args → m io.error child) (wait : child → m io.error nat) */ static vm_obj monad_io_process_impl() { return mk_vm_constructor(0, { mk_native_closure([] (vm_obj const & c) { return to_obj(to_child(c)->get_stdin()); }), mk_native_closure([] (vm_obj const & c) { return to_obj(to_child(c)->get_stdout()); }), mk_native_closure([] (vm_obj const & c) { return to_obj(to_child(c)->get_stderr()); }), mk_native_closure(io_process_spawn), mk_native_closure(io_process_wait), }); } static vm_obj io_return(vm_obj const &, vm_obj const & a, vm_obj const &) { return mk_io_result(a); } static vm_obj io_bind(vm_obj const & /* α */, vm_obj const & /* β */, vm_obj const & a, vm_obj const & b, vm_obj const &) { vm_obj r = invoke(a, mk_vm_unit()); if (cidx(r) == 0) { vm_obj v = cfield(r, 0); return invoke(b, v, mk_vm_unit()); } else { return r; } } static vm_obj io_monad(vm_obj const &) { vm_state & S = get_vm_state(); vm_obj const & mk_monad = S.get_constant(get_monad_from_pure_bind_name()); return invoke(mk_monad, mk_vm_simple(0), mk_native_closure(io_return), mk_native_closure(io_bind)); } static vm_obj io_catch(vm_obj const &, vm_obj const &, vm_obj const &, vm_obj const & a, vm_obj const & b, vm_obj const &) { vm_obj r = invoke(a, mk_vm_unit()); if (cidx(r) == 1) { vm_obj e = cfield(r, 0); return invoke(b, e, mk_vm_unit()); } else { return r; } } static vm_obj io_fail(vm_obj const &, vm_obj const &, vm_obj const & e, vm_obj const &) { return mk_io_failure(e); } /* (iterate : Π e α, α → (α → m e (option α)) → m e α) */ static vm_obj io_iterate(vm_obj const &, vm_obj const &, vm_obj const & a, vm_obj const & fn, vm_obj const &) { vm_obj r = a; while (true) { vm_obj p = invoke(fn, r, mk_vm_unit()); if (cidx(p) == 1) { return p; } else { vm_obj v = cfield(p, 0); if (is_none(v)) { return mk_io_result(r); } else { r = get_some_value(v); } } } } static vm_obj io_get_env(vm_obj const & k, vm_obj const &) { if (auto v = getenv(to_string(k).c_str())) { return mk_io_result(mk_vm_some(to_obj(std::string(v)))); } else { return mk_io_result(mk_vm_none()); } } static vm_obj io_get_cwd(vm_obj const &) { char buffer[PATH_MAX]; auto cwd = getcwd(buffer, sizeof(buffer)); if (cwd) { return mk_io_result(mk_vm_some(to_obj(std::string(cwd)))); } else { return mk_io_failure("get_cwd failed"); } } static vm_obj io_set_cwd(vm_obj const & cwd, vm_obj const &) { if (chdir(to_string(cwd).c_str()) == 0) { return mk_io_result(mk_vm_unit()); } else { return mk_io_failure("set_cwd failed"); } } /* class monad_io_environment (m : Type → Type → Type) := (get_env : string → m io.error (option string)) -- we don't provide set_env as it is (thread-)unsafe (at least with glibc) (get_cwd : m io.error string) (set_cwd : string → m io.error unit) */ vm_obj monad_io_environment_impl() { return mk_vm_constructor(0, { mk_native_closure(io_get_env), mk_native_closure(io_get_cwd), mk_native_closure(io_set_cwd), }); } /* class monad_io (m : Type → Type → Type) := [monad : Π e, monad (m e)] -- TODO(Leo): use monad_except after it is merged (catch : Π e₁ e₂ α, m e₁ α → (e₁ → m e₂ α) → m e₂ α) (fail : Π e α, e → m e α) (iterate : Π e α, α → (α → m e (option α)) → m e α) -- Primitive Types (handle : Type) */ vm_obj monad_io_impl() { return mk_vm_constructor(0, { mk_native_closure(io_monad), mk_native_closure(io_catch), mk_native_closure(io_fail), mk_native_closure(io_iterate)}); /* field handle is erased */ } static std::vector * g_cmdline_args = nullptr; void set_io_cmdline_args(std::vector const & args) { *g_cmdline_args = args; } /* class monad_io_terminal (m : Type → Type → Type) := (put_str : string → m io.error unit) (get_line : m io.error string) (cmdline_args : list string) */ vm_obj monad_io_terminal_impl() { return mk_vm_constructor(0, { mk_native_closure(io_put_str), mk_native_closure(io_get_line), cmdline_args_to_obj(*g_cmdline_args)}); } optional is_io_result(vm_obj const & o) { if (cidx(o) == 0) return some(cfield(o, 0)); else return optional(); } optional is_io_error(vm_obj const & o) { if (cidx(o) == 1) return some(cfield(o, 0)); else return optional(); } /* inductive io.error | other : string → io.error | sys : nat → io.error */ std::string io_error_to_string(vm_obj const & o) { if (cidx(o) == 0) { return to_string(cfield(o, 0)); } else if (cidx(o) == 1) { return (sstream() << "system error #" << to_unsigned(cfield(o, 0))).str(); } lean_vm_check(false); lean_unreachable(); } MK_THREAD_LOCAL_GET_DEF(vm_obj, get_rand_gen); vm_obj io_set_rand_gen(vm_obj const & g, vm_obj const &) { get_rand_gen() = g; return mk_io_result(mk_vm_unit()); } vm_obj io_rand(vm_obj const & lo, vm_obj const & hi, vm_obj const &) { vm_obj & gen = get_rand_gen(); if (is_simple(gen)) { if (optional lo1 = try_to_unsigned(lo)) { if (optional hi1 = try_to_unsigned(hi)) { unsigned r = 0; if (*lo1 < *hi1) { r = *lo1 + (std::rand() % (*hi1 - *lo1)); // NOLINT } return mk_io_result(mk_vm_nat(r)); } } mpz const & lo1 = vm_nat_to_mpz1(lo); mpz const & hi1 = vm_nat_to_mpz2(hi); mpz r(0); if (lo1 < hi1) { r = lo1 + (mpz(std::rand()) % (hi1 - lo1)); // NOLINT } return mk_io_result(mk_vm_nat(r)); } else { return mk_io_failure("not implemented yet, io_rand_nat primitive has been deleted"); } } vm_obj monad_io_random_impl() { return mk_vm_constructor(0, { mk_native_closure(io_set_rand_gen), mk_native_closure(io_rand) }); } void initialize_vm_io() { DECLARE_VM_BUILTIN(name("io_core"), io_core); DECLARE_VM_BUILTIN(name("monad_io_impl"), monad_io_impl); DECLARE_VM_BUILTIN(name("monad_io_terminal_impl"), monad_io_terminal_impl); DECLARE_VM_BUILTIN(name("monad_io_file_system_impl"), monad_io_file_system_impl); DECLARE_VM_BUILTIN(name("monad_io_environment_impl"), monad_io_environment_impl); DECLARE_VM_BUILTIN(name("monad_io_process_impl"), monad_io_process_impl); DECLARE_VM_BUILTIN(name("monad_io_random_impl"), monad_io_random_impl); g_cmdline_args = new std::vector(); } void finalize_vm_io() { delete g_cmdline_args; } }