From 2eb99a728312a67a491693a32a7ac5a87189b7ff Mon Sep 17 00:00:00 2001 From: XeroOl Date: Wed, 22 Feb 2023 23:36:14 -0600 Subject: [PATCH] Update fennel to version 1.3.1 There is a new fennel branch on my fork of fennel called extra-hooks-3 which is up to date with fennel 1.3.1 and has the extra hooks necessary for the server. Also, some of the error messages need to be updated to match with fennel 1.3.1's changes. --- fennel | 3746 ++++++++++++++++++------------------ src/fennel-ls/compiler.fnl | 14 +- src/fennel.lua | 3419 ++++++++++++++++---------------- test/diagnostic-test.fnl | 2 +- 4 files changed, 3549 insertions(+), 3632 deletions(-) diff --git a/fennel b/fennel index f7222f7..e364a16 100755 --- a/fennel +++ b/fennel @@ -1,22 +1,20 @@ #!/usr/bin/env lua package.preload["fennel.binary"] = package.preload["fennel.binary"] or function(...) local fennel = require("fennel") - local _local_771_ = require("fennel.utils") - local warn = _local_771_["warn"] - local copy = _local_771_["copy"] + local _743_ = require("fennel.utils") + local copy = _743_["copy"] + local warn = _743_["warn"] local function shellout(command) local f = io.popen(command) local stdout = f:read("*all") return (f:close() and stdout) end local function execute(cmd) - local _772_ = os.execute(cmd) - if (_772_ == 0) then + local _744_0 = os.execute(cmd) + if (_744_0 == 0) then return true - elseif (_772_ == true) then + elseif (_744_0 == true) then return true - else - return nil end end local function string__3ec_hex_literal(characters) @@ -28,7 +26,7 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( end local c_shim = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n#include \n#include \n#include \n#ifdef __cplusplus\n}\n#endif\n#include \n#include \n#include \n#include \n\n#if LUA_VERSION_NUM == 501\n #define LUA_OK 0\n#endif\n\n/* Copied from lua.c */\n\nstatic lua_State *globalL = NULL;\n\nstatic void lstop (lua_State *L, lua_Debug *ar) {\n (void)ar; /* unused arg. */\n lua_sethook(L, NULL, 0, 0); /* reset hook */\n luaL_error(L, \"interrupted!\");\n}\n\nstatic void laction (int i) {\n signal(i, SIG_DFL); /* if another SIGINT happens, terminate process */\n lua_sethook(globalL, lstop, LUA_MASKCALL | LUA_MASKRET | LUA_MASKCOUNT, 1);\n}\n\nstatic void createargtable (lua_State *L, char **argv, int argc, int script) {\n int i, narg;\n if (script == argc) script = 0; /* no script name? */\n narg = argc - (script + 1); /* number of positive indices */\n lua_createtable(L, narg, script + 1);\n for (i = 0; i < argc; i++) {\n lua_pushstring(L, argv[i]);\n lua_rawseti(L, -2, i - script);\n }\n lua_setglobal(L, \"arg\");\n}\n\nstatic int msghandler (lua_State *L) {\n const char *msg = lua_tostring(L, 1);\n if (msg == NULL) { /* is error object not a string? */\n if (luaL_callmeta(L, 1, \"__tostring\") && /* does it have a metamethod */\n lua_type(L, -1) == LUA_TSTRING) /* that produces a string? */\n return 1; /* that is the message */\n else\n msg = lua_pushfstring(L, \"(error object is a %%s value)\",\n luaL_typename(L, 1));\n }\n /* Call debug.traceback() instead of luaL_traceback() for Lua 5.1 compat. */\n lua_getglobal(L, \"debug\");\n lua_getfield(L, -1, \"traceback\");\n /* debug */\n lua_remove(L, -2);\n lua_pushstring(L, msg);\n /* original msg */\n lua_remove(L, -3);\n lua_pushinteger(L, 2); /* skip this function and traceback */\n lua_call(L, 2, 1); /* call debug.traceback */\n return 1; /* return the traceback */\n}\n\nstatic int docall (lua_State *L, int narg, int nres) {\n int status;\n int base = lua_gettop(L) - narg; /* function index */\n lua_pushcfunction(L, msghandler); /* push message handler */\n lua_insert(L, base); /* put it under function and args */\n globalL = L; /* to be available to 'laction' */\n signal(SIGINT, laction); /* set C-signal handler */\n status = lua_pcall(L, narg, nres, base);\n signal(SIGINT, SIG_DFL); /* reset C-signal handler */\n lua_remove(L, base); /* remove message handler from the stack */\n return status;\n}\n\nint main(int argc, char *argv[]) {\n lua_State *L = luaL_newstate();\n luaL_openlibs(L);\n createargtable(L, argv, argc, 0);\n\n static const unsigned char lua_loader_program[] = {\n%s\n};\n if(luaL_loadbuffer(L, (const char*)lua_loader_program,\n sizeof(lua_loader_program), \"%s\") != LUA_OK) {\n fprintf(stderr, \"luaL_loadbuffer: %%s\\n\", lua_tostring(L, -1));\n lua_close(L);\n return 1;\n }\n\n /* lua_bundle */\n lua_newtable(L);\n static const unsigned char lua_require_1[] = {\n %s\n };\n lua_pushlstring(L, (const char*)lua_require_1, sizeof(lua_require_1));\n lua_setfield(L, -2, \"%s\");\n\n%s\n\n if (docall(L, 1, LUA_MULTRET)) {\n const char *errmsg = lua_tostring(L, 1);\n if (errmsg) {\n fprintf(stderr, \"%%s\\n\", errmsg);\n }\n lua_close(L);\n return 1;\n }\n lua_close(L);\n return 0;\n}" local function compile_fennel(filename, options) - local f + local f = nil if (filename == "-") then f = io.stdin else @@ -39,18 +37,16 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( return lua_code end local function module_name(open, rename, used_renames) - local require_name + local require_name = nil do - local _775_ = rename[open] - if (nil ~= _775_) then - local renamed = _775_ + local _747_0 = rename[open] + if (nil ~= _747_0) then + local renamed = _747_0 used_renames[open] = true require_name = renamed - elseif true then - local _ = _775_ - require_name = open else - require_name = nil + local _ = _747_0 + require_name = open end end return (require_name:sub(1, 1) .. require_name:sub(2):gsub("_", ".")) @@ -68,7 +64,6 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( end if (0 == #opens) then warn((("Native module %s did not contain any luaopen_* symbols. " .. "Did you mean to use --native-library instead of --native-module?")):format(path)) - else end for _0, open in ipairs(opens) do table.insert(out, (" int luaopen_%s(lua_State *L);"):format(open)) @@ -79,7 +74,6 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( for key, val in pairs(rename) do if not used_renames[key] then warn((("unused --rename-native-module %s %s argument. " .. "Did you mean to include a native module?")):format(key, val)) - else end end return table.concat(out, "\n") @@ -89,15 +83,15 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( local basename_noextension = (basename:match("(.+)%.") or basename) local dotpath = filename:gsub("^%.%/", ""):gsub("[\\/]", ".") local dotpath_noextension = (dotpath:match("(.+)%.") or dotpath) - local fennel_loader - local _779_ + local fennel_loader = nil + local _751_ do - _779_ = "(do (local bundle_2_auto ...) (fn loader_3_auto [name_4_auto] (match (or (. bundle_2_auto name_4_auto) (. bundle_2_auto (.. name_4_auto \".init\"))) (mod_5_auto ? (= \"function\" (type mod_5_auto))) mod_5_auto (mod_5_auto ? (= \"string\" (type mod_5_auto))) (assert (if (= _VERSION \"Lua 5.1\") (loadstring mod_5_auto name_4_auto) (load mod_5_auto name_4_auto))) nil (values nil (: \"\n\\tmodule '%%s' not found in fennel bundle\" \"format\" name_4_auto)))) (table.insert (or package.loaders package.searchers) 2 loader_3_auto) ((assert (loader_3_auto \"%s\")) ((or unpack table.unpack) arg)))" + _751_ = "(do (local bundle_2_ ...) (fn loader_3_ [name_4_] (match (or (. bundle_2_ name_4_) (. bundle_2_ (.. name_4_ \".init\"))) (mod_5_ ? (= \"function\" (type mod_5_))) mod_5_ (mod_5_ ? (= \"string\" (type mod_5_))) (assert (if (= _VERSION \"Lua 5.1\") (loadstring mod_5_ name_4_) (load mod_5_ name_4_))) nil (values nil (: \"\n\\tmodule '%%s' not found in fennel bundle\" \"format\" name_4_)))) (table.insert (or package.loaders package.searchers) 2 loader_3_) ((assert (loader_3_ \"%s\")) ((or unpack table.unpack) arg)))" end - fennel_loader = _779_:format(dotpath_noextension) + fennel_loader = _751_:format(dotpath_noextension) local lua_loader = fennel["compile-string"](fennel_loader) - local _let_780_ = options - local rename_modules = _let_780_["rename-modules"] + local _752_ = options + local rename_modules = _752_["rename-modules"] return c_shim:format(string__3ec_hex_literal(lua_loader), basename_noextension, string__3ec_hex_literal(compile_fennel(filename, options)), dotpath_noextension, native_loader(native, {["rename-modules"] = rename_modules})) end local function write_c(filename, native, options) @@ -110,40 +104,37 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( local function compile_binary(lua_c_path, executable_name, static_lua, lua_include_dir, native) local cc = (os.getenv("CC") or "cc") local rdynamic, bin_extension, ldl_3f = nil, nil, nil - local _782_ + local _754_ do - local _781_ = shellout((cc .. " -dumpmachine")) - if (nil ~= _781_) then - _782_ = _781_:match("mingw") + local _753_0 = shellout((cc .. " -dumpmachine")) + if (nil ~= _753_0) then + _754_ = _753_0:match("mingw") else - _782_ = _781_ + _754_ = _753_0 end end - if _782_ then + if _754_ then rdynamic, bin_extension, ldl_3f = "", ".exe", false else rdynamic, bin_extension, ldl_3f = "-rdynamic", "", true end - local compile_command - local _785_ + local compile_command = nil + local _757_ if ldl_3f then - _785_ = "-ldl" + _757_ = "-ldl" else - _785_ = "" + _757_ = "" end - compile_command = {cc, "-Os", lua_c_path, table.concat(native, " "), static_lua, rdynamic, "-lm", _785_, "-o", (executable_name .. bin_extension), "-I", lua_include_dir, os.getenv("CC_OPTS")} + compile_command = {cc, "-Os", lua_c_path, table.concat(native, " "), static_lua, rdynamic, "-lm", _757_, "-o", (executable_name .. bin_extension), "-I", lua_include_dir, os.getenv("CC_OPTS")} if os.getenv("FENNEL_DEBUG") then print("Compiling with", table.concat(compile_command, " ")) - else end if not execute(table.concat(compile_command, " ")) then print("failed:", table.concat(compile_command, " ")) os.exit(1) - else end if not os.getenv("FENNEL_DEBUG") then os.remove(lua_c_path) - else end return os.exit(0) end @@ -152,66 +143,60 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( if (version_extension and (version_extension ~= "") and not version_extension:match("%.%d+")) then return false else - local _790_ = extension - if (_790_ == "a") then + local _762_0 = extension + if (_762_0 == "a") then return path - elseif (_790_ == "o") then + elseif (_762_0 == "o") then return path - elseif (_790_ == "so") then + elseif (_762_0 == "so") then return path - elseif (_790_ == "dylib") then + elseif (_762_0 == "dylib") then return path - elseif true then - local _ = _790_ - return false else - return nil + local _ = _762_0 + return false end end end local function extract_native_args(args) - local native = {modules = {}, libraries = {}, ["rename-modules"] = {}} + local native = {["rename-modules"] = {}, libraries = {}, modules = {}} for i = #args, 1, -1 do if ("--native-module" == args[i]) then local path = assert(native_path_3f(table.remove(args, (i + 1)))) table.insert(native.modules, 1, path) table.insert(native.libraries, 1, path) table.remove(args, i) - else end if ("--native-library" == args[i]) then table.insert(native.libraries, 1, assert(native_path_3f(table.remove(args, (i + 1))))) table.remove(args, i) - else end if ("--rename-native-module" == args[i]) then local original = table.remove(args, (i + 1)) local new = table.remove(args, (i + 1)) - do end (native["rename-modules"])[original] = new + native["rename-modules"][original] = new table.remove(args, i) - else end end if (0 < #args) then print(table.concat(args, " ")) error(("Unknown args: " .. table.concat(args, " "))) - else end return native end local function compile(filename, executable_name, static_lua, lua_include_dir, options, args) - local _let_797_ = extract_native_args(args) - local modules = _let_797_["modules"] - local libraries = _let_797_["libraries"] - local rename_modules = _let_797_["rename-modules"] + local _769_ = extract_native_args(args) + local libraries = _769_["libraries"] + local modules = _769_["modules"] + local rename_modules = _769_["rename-modules"] local opts = {["rename-modules"] = rename_modules} copy(options, opts) return compile_binary(write_c(filename, modules, opts), executable_name, static_lua, lua_include_dir, libraries) end - local help = ("\nUsage: %s --compile-binary FILE OUT STATIC_LUA_LIB LUA_INCLUDE_DIR\n\nCompile a binary from your Fennel program.\n\nRequires a C compiler, a copy of liblua, and Lua's dev headers. Implies\nthe --require-as-include option.\n\n FILE: the Fennel source being compiled.\n OUT: the name of the executable to generate\n STATIC_LUA_LIB: the path to the Lua library to use in the executable\n LUA_INCLUDE_DIR: the path to the directory of Lua C header files\n\nFor example, on a Debian system, to compile a file called program.fnl using\nLua 5.3, you would use this:\n\n $ %s --compile-binary program.fnl program \\\n /usr/lib/x86_64-linux-gnu/liblua5.3.a /usr/include/lua5.3\n\nThe program will be compiled to Lua, then compiled to C, then compiled to\nmachine code. You can set the CC environment variable to change the compiler\nused (default: cc) or set CC_OPTS to pass in compiler options. For example\nset CC_OPTS=-static to generate a binary with static linking.\n\nThis method is currently limited to programs do not transitively require Lua\nmodules. Requiring a Lua module directly will work, but requiring a Lua module\nwhich requires another will fail.\n\nTo include C libraries that contain Lua modules, add --native-module path/to.so,\nand to include C libraries without modules, use --native-library path/to.so.\nThese options are unstable, barely tested, and even more likely to break.\n\nIf you need to change the require name that a given native module is referenced\nas, you can use the --rename-native-module ORIGINAL NEW. ORIGINAL should be the\nsuffix of the luaopen_* symbol in the native module. NEW should be the string\nyou wish to pass to require to require the given native module. This can be used\nto handle cases where the name of an object file does not match the name of the\nluaopen_* symbol(s) within it. For example, the Lua readline bindings include a\nreadline.lua file which is usually required as \"readline\", and a C-readline.so\nfile which is required in the Lua half of the bindings like so:\n\n require 'C-readline'\n\nHowever, the symbol within the C-readline.so file is named luaopen_readline, so\nby default --compile-binary will make it so you can require it as \"readline\",\nwhich collides with the name of the readline.lua file and doesn't match the\nrequire call within readline.lua. In order to include the module within your\ncompiled binary and have it get picked up by readline.lua correctly, you can\nspecify the name used to refer to it in a require call by compiling it like\nso (this is assuming that program.fnl requires the Lua bindings):\n\n $ %s --compile-binary program.fnl program \\\n /usr/lib/x86_64-linux-gnu/liblua5.3.a /usr/include/lua5.3 \\\n --native-module C-readline.so \\\n --rename-native-module readline C-readline\n"):format(arg[0], arg[0], arg[0]) + local help = "\nUsage: %s --compile-binary FILE OUT STATIC_LUA_LIB LUA_INCLUDE_DIR\n\nCompile a binary from your Fennel program.\n\nRequires a C compiler, a copy of liblua, and Lua's dev headers. Implies\nthe --require-as-include option.\n\n FILE: the Fennel source being compiled.\n OUT: the name of the executable to generate\n STATIC_LUA_LIB: the path to the Lua library to use in the executable\n LUA_INCLUDE_DIR: the path to the directory of Lua C header files\n\nFor example, on a Debian system, to compile a file called program.fnl using\nLua 5.3, you would use this:\n\n $ %s --compile-binary program.fnl program \\\n /usr/lib/x86_64-linux-gnu/liblua5.3.a /usr/include/lua5.3\n\nThe program will be compiled to Lua, then compiled to C, then compiled to\nmachine code. You can set the CC environment variable to change the compiler\nused (default: cc) or set CC_OPTS to pass in compiler options. For example\nset CC_OPTS=-static to generate a binary with static linking.\n\nThis method is currently limited to programs do not transitively require Lua\nmodules. Requiring a Lua module directly will work, but requiring a Lua module\nwhich requires another will fail.\n\nTo include C libraries that contain Lua modules, add --native-module path/to.so,\nand to include C libraries without modules, use --native-library path/to.so.\nThese options are unstable, barely tested, and even more likely to break.\n\nIf you need to change the require name that a given native module is referenced\nas, you can use the --rename-native-module ORIGINAL NEW. ORIGINAL should be the\nsuffix of the luaopen_* symbol in the native module. NEW should be the string\nyou wish to pass to require to require the given native module. This can be used\nto handle cases where the name of an object file does not match the name of the\nluaopen_* symbol(s) within it. For example, the Lua readline bindings include a\nreadline.lua file which is usually required as \"readline\", and a C-readline.so\nfile which is required in the Lua half of the bindings like so:\n\n require 'C-readline'\n\nHowever, the symbol within the C-readline.so file is named luaopen_readline, so\nby default --compile-binary will make it so you can require it as \"readline\",\nwhich collides with the name of the readline.lua file and doesn't match the\nrequire call within readline.lua. In order to include the module within your\ncompiled binary and have it get picked up by readline.lua correctly, you can\nspecify the name used to refer to it in a require call by compiling it like\nso (this is assuming that program.fnl requires the Lua bindings):\n\n $ %s --compile-binary program.fnl program \\\n /usr/lib/x86_64-linux-gnu/liblua5.3.a /usr/include/lua5.3 \\\n --native-module C-readline.so \\\n --rename-native-module readline C-readline\n" return {compile = compile, help = help} end -local fennel +local fennel = nil package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local utils = require("fennel.utils") local parser = require("fennel.parser") @@ -220,14 +205,14 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local view = require("fennel.view") local unpack = (table.unpack or _G.unpack) local function default_read_chunk(parser_state) - local function _621_() + local function _591_() if (0 < parser_state["stack-size"]) then return ".." else return ">> " end end - io.write(_621_()) + io.write(_591_()) io.flush() local input = io.read() return (input and (input .. "\n")) @@ -237,41 +222,76 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) return io.write("\n") end local function default_on_error(errtype, err, lua_source) - local function _623_() - local _622_ = errtype - if (_622_ == "Lua Compile") then + local function _593_() + local _592_0 = errtype + if (_592_0 == "Lua Compile") then return ("Bad code generated - likely a bug with the compiler:\n" .. "--- Generated Lua Start ---\n" .. lua_source .. "--- Generated Lua End ---\n") - elseif (_622_ == "Runtime") then + elseif (_592_0 == "Runtime") then return (compiler.traceback(tostring(err), 4) .. "\n") - elseif true then - local _ = _622_ - return ("%s error: %s\n"):format(errtype, tostring(err)) else - return nil + local _ = _592_0 + return ("%s error: %s\n"):format(errtype, tostring(err)) end end - return io.write(_623_()) + return io.write(_593_()) end - local save_source = " ___replLocals___['%s'] = %s" local function splice_save_locals(env, lua_source, scope) - local spliced_source = {} - local bind = "local %s = ___replLocals___['%s']" - for line in lua_source:gmatch("([^\n]+)\n?") do - table.insert(spliced_source, line) - end - for name in pairs(env.___replLocals___) do - table.insert(spliced_source, 1, bind:format(name, name)) - end - if ((1 < #spliced_source) and (spliced_source[#spliced_source]):match("^ *return .*$")) then - for _, name in pairs(scope.manglings) do - if not scope.gensyms[name] then - table.insert(spliced_source, #spliced_source, save_source:format(name, name)) - else + local saves = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for name in pairs(env.___replLocals___) do + local val_19_ = ("local %s = ___replLocals___['%s']"):format(name, name) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - else + saves = tbl_17_ end - return table.concat(spliced_source, "\n") + local binds = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, name in pairs(scope.manglings) do + local val_19_ = nil + if not scope.gensyms[name] then + val_19_ = ("___replLocals___['%s'] = %s"):format(name, name) + else + val_19_ = nil + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + binds = tbl_17_ + end + local gap = nil + if lua_source:find("\n") then + gap = "\n" + else + gap = " " + end + local function _599_() + if next(saves) then + return (table.concat(saves, " ") .. gap) + else + return "" + end + end + local function _602_() + local _600_0, _601_0 = lua_source:match("^(.*)[\n ](return .*)$") + if ((nil ~= _600_0) and (nil ~= _601_0)) then + local body = _600_0 + local _return = _601_0 + return (body .. gap .. table.concat(binds, " ") .. gap .. _return) + else + local _ = _600_0 + return lua_source + end + end + return (_599_() .. _602_()) end local function completer(env, scope, text) local max_items = 2000 @@ -281,20 +301,20 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local stop_looking_3f = false local function add_partials(input, tbl, prefix) local scope_first_3f = ((tbl == env) or (tbl == env.___replLocals___)) - local tbl_14_auto = matches - local i_15_auto = #tbl_14_auto - local function _627_() + local tbl_17_ = matches + local i_18_ = #tbl_17_ + local function _604_() if scope_first_3f then return scope.manglings else return tbl end end - for k, is_mangled in utils.allpairs(_627_()) do + for k, is_mangled in utils.allpairs(_604_()) do if (max_items <= #matches) then break end - local val_16_auto + local val_19_ = nil do - local lookup_k + local lookup_k = nil if scope_first_3f then lookup_k = is_mangled else @@ -302,21 +322,20 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end if ((type(k) == "string") and (input == k:sub(0, #input)) and not seen[k] and ((":" ~= prefix:sub(-1)) or ("function" == type(tbl[lookup_k])))) then seen[k] = true - val_16_auto = (prefix .. k) + val_19_ = (prefix .. k) else - val_16_auto = nil + val_19_ = nil end end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_14_auto + return tbl_17_ end local function descend(input, tbl, prefix, add_matches, method_3f) - local splitter + local splitter = nil if method_3f then splitter = "^([^:]+):(.*)" else @@ -331,12 +350,10 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) else return add_matches(tail, tbl[raw_head], (prefix .. head)) end - else - return nil end end local function add_matches(input, tbl, prefix) - local prefix0 + local prefix0 = nil if prefix then prefix0 = (prefix .. ".") else @@ -361,35 +378,34 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) return input:match("^%s*,") end local function command_docs() - local _636_ + local _613_ do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for name, f in pairs(commands) do - local val_16_auto = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _636_ = tbl_14_auto + _613_ = tbl_17_ end - return table.concat(_636_, "\n") + return table.concat(_613_, "\n") end commands.help = function(_, _0, on_values) return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference")}) end do end (compiler.metadata):set(commands.help, "fnl/docstring", "Show this message.") local function reload(module_name, env, on_values, on_error) - local _638_, _639_ = pcall(specials["load-code"]("return require(...)", env), module_name) - if ((_638_ == true) and (nil ~= _639_)) then - local old = _639_ - local _ + local _615_0, _616_0 = pcall(specials["load-code"]("return require(...)", env), module_name) + if ((_615_0 == true) and (nil ~= _616_0)) then + local old = _616_0 + local _ = nil package.loaded[module_name] = nil _ = nil local ok, new = pcall(require, module_name) - local new0 + local new0 = nil if not ok then on_values({new}) new0 = old @@ -402,47 +418,44 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) old[k] = v end for k in pairs(old) do - if (nil == (new0)[k]) then + if (nil == new0[k]) then old[k] = nil - else end end package.loaded[module_name] = old - else end return on_values({"ok"}) - elseif ((_638_ == false) and (nil ~= _639_)) then - local msg = _639_ - if (specials["macro-loaded"])[module_name] then + elseif ((_615_0 == false) and (nil ~= _616_0)) then + local msg = _616_0 + if msg:match("loop or previous error loading module") then + package.loaded[module_name] = nil + return reload(module_name, env, on_values, on_error) + elseif specials["macro-loaded"][module_name] then specials["macro-loaded"][module_name] = nil return nil else - local function _644_() - local _643_ = msg:gsub("\n.*", "") - return _643_ + local function _621_() + local _620_0 = msg:gsub("\n.*", "") + return _620_0 end - return on_error("Runtime", _644_()) + return on_error("Runtime", _621_()) end - else - return nil end end local function run_command(read, on_error, f) - local _647_, _648_, _649_ = pcall(read) - if ((_647_ == true) and (_648_ == true) and (nil ~= _649_)) then - local val = _649_ + local _624_0, _625_0, _626_0 = pcall(read) + if ((_624_0 == true) and (_625_0 == true) and (nil ~= _626_0)) then + local val = _626_0 return f(val) - elseif (_647_ == false) then + elseif (_624_0 == false) then return on_error("Parse", "Couldn't parse input.") - else - return nil end end commands.reload = function(env, read, on_values, on_error) - local function _651_(_241) + local function _628_(_241) return reload(tostring(_241), env, on_values, on_error) end - return run_command(read, on_error, _651_) + return run_command(read, on_error, _628_) end do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.") commands.reset = function(env, _, on_values) @@ -451,119 +464,111 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.") commands.complete = function(env, read, on_values, on_error, scope, chars) - local function _652_() + local function _629_() return on_values(completer(env, scope, string.char(unpack(chars)):gsub(",complete +", ""):sub(1, -2))) end - return run_command(read, on_error, _652_) + return run_command(read, on_error, _629_) end do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input symbol.") local function apropos_2a(pattern, tbl, prefix, seen, names) for name, subtbl in pairs(tbl) do if (("string" == type(name)) and (package ~= subtbl)) then - local _653_ = type(subtbl) - if (_653_ == "function") then + local _630_0 = type(subtbl) + if (_630_0 == "function") then if ((prefix .. name)):match(pattern) then table.insert(names, (prefix .. name)) - else end - elseif (_653_ == "table") then + elseif (_630_0 == "table") then if not seen[subtbl] then - local _656_ + local _632_ do - local _655_ = seen - _655_[subtbl] = true - _656_ = _655_ + seen[subtbl] = true + _632_ = seen end - apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _656_, names) - else + apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _632_, names) end - else end - else end end return names end local function apropos(pattern) local names = apropos_2a(pattern, package.loaded, "", {}, {}) - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, name in ipairs(names) do - local val_16_auto = name:gsub("^_G%.", "") - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = name:gsub("^_G%.", "") + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_14_auto + return tbl_17_ end commands.apropos = function(_env, read, on_values, on_error, _scope) - local function _661_(_241) + local function _637_(_241) return on_values(apropos(tostring(_241))) end - return run_command(read, on_error, _661_) + return run_command(read, on_error, _637_) end do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.") local function apropos_follow_path(path) - local paths + local paths = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for p in path:gmatch("[^%.]+") do - local val_16_auto = p - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = p + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - paths = tbl_14_auto + paths = tbl_17_ end local tgt = package.loaded for _, path0 in ipairs(paths) do if (nil == tgt) then break end - local _664_ + local _640_ do - local _663_ = path0:gsub("%/", ".") - _664_ = _663_ + local _639_0 = path0:gsub("%/", ".") + _640_ = _639_0 end - tgt = tgt[_664_] + tgt = tgt[_640_] end return tgt end local function apropos_doc(pattern) - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, path in ipairs(apropos(".*")) do - local val_16_auto + local val_19_ = nil do local tgt = apropos_follow_path(path) if ("function" == type(tgt)) then - local _665_ = (compiler.metadata):get(tgt, "fnl/docstring") - if (nil ~= _665_) then - local docstr = _665_ - val_16_auto = (docstr:match(pattern) and path) + local _641_0 = (compiler.metadata):get(tgt, "fnl/docstring") + if (nil ~= _641_0) then + local docstr = _641_0 + val_19_ = (docstr:match(pattern) and path) else - val_16_auto = nil + val_19_ = nil end else - val_16_auto = nil + val_19_ = nil end end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_14_auto + return tbl_17_ end commands["apropos-doc"] = function(_env, read, on_values, on_error, _scope) - local function _669_(_241) + local function _645_(_241) return on_values(apropos_doc(tostring(_241))) end - return run_command(read, on_error, _669_) + return run_command(read, on_error, _645_) end do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs") local function apropos_show_docs(on_values, pattern) @@ -572,124 +577,115 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) if (("function" == type(tgt)) and (compiler.metadata):get(tgt, "fnl/docstring")) then on_values(specials.doc(tgt, path)) on_values() - else end end return nil end commands["apropos-show-docs"] = function(_env, read, on_values, on_error) - local function _671_(_241) + local function _647_(_241) return apropos_show_docs(on_values, tostring(_241)) end - return run_command(read, on_error, _671_) + return run_command(read, on_error, _647_) end do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name") - local function resolve(identifier, _672_, scope) - local _arg_673_ = _672_ - local ___replLocals___ = _arg_673_["___replLocals___"] - local env = _arg_673_ - local e - local function _674_(_241, _242) + local function resolve(identifier, _648_0, scope) + local _649_ = _648_0 + local env = _649_ + local ___replLocals___ = _649_["___replLocals___"] + local e = nil + local function _650_(_241, _242) return (___replLocals___[_242] or env[_242]) end - e = setmetatable({}, {__index = _674_}) - local _675_, _676_ = pcall(compiler["compile-string"], tostring(identifier), {scope = scope}) - if ((_675_ == true) and (nil ~= _676_)) then - local code = _676_ + e = setmetatable({}, {__index = _650_}) + local _651_0, _652_0 = pcall(compiler["compile-string"], tostring(identifier), {scope = scope}) + if ((_651_0 == true) and (nil ~= _652_0)) then + local code = _652_0 return specials["load-code"](code, e)() - else - return nil end end commands.find = function(env, read, on_values, on_error, scope) - local function _678_(_241) - local _679_ + local function _654_(_241) + local _655_0 = nil do - local _680_ = utils["sym?"](_241) - if (nil ~= _680_) then - local _681_ = resolve(_680_, env, scope) - if (nil ~= _681_) then - _679_ = debug.getinfo(_681_) + local _656_0 = utils["sym?"](_241) + if (nil ~= _656_0) then + local _657_0 = resolve(_656_0, env, scope) + if (nil ~= _657_0) then + _655_0 = debug.getinfo(_657_0) else - _679_ = _681_ + _655_0 = _657_0 end else - _679_ = _680_ + _655_0 = _656_0 end end - if ((_G.type(_679_) == "table") and ((_679_).what == "Lua") and (nil ~= (_679_).source) and (nil ~= (_679_).linedefined) and (nil ~= (_679_).short_src)) then - local source = (_679_).source - local line = (_679_).linedefined - local src = (_679_).short_src - local fnlsrc + if ((_G.type(_655_0) == "table") and (nil ~= _655_0.linedefined) and (nil ~= _655_0.short_src) and (nil ~= _655_0.source) and (_655_0.what == "Lua")) then + local line = _655_0.linedefined + local src = _655_0.short_src + local source = _655_0.source + local fnlsrc = nil do - local t_684_ = compiler.sourcemap - if (nil ~= t_684_) then - t_684_ = (t_684_)[source] - else + local _660_0 = compiler.sourcemap + if (nil ~= _660_0) then + _660_0 = _660_0[source] end - if (nil ~= t_684_) then - t_684_ = (t_684_)[line] - else + if (nil ~= _660_0) then + _660_0 = _660_0[line] end - if (nil ~= t_684_) then - t_684_ = (t_684_)[2] - else + if (nil ~= _660_0) then + _660_0 = _660_0[2] end - fnlsrc = t_684_ + fnlsrc = _660_0 end return on_values({string.format("%s:%s", src, (fnlsrc or line))}) - elseif (_679_ == nil) then + elseif (_655_0 == nil) then return on_error("Repl", "Unknown value") - elseif true then - local _ = _679_ - return on_error("Repl", "No source info") else - return nil + local _ = _655_0 + return on_error("Repl", "No source info") end end - return run_command(read, on_error, _678_) + return run_command(read, on_error, _654_) end do end (compiler.metadata):set(commands.find, "fnl/docstring", "Print the filename and line number for a given function") commands.doc = function(env, read, on_values, on_error, scope) - local function _689_(_241) + local function _665_(_241) local name = tostring(_241) local path = (utils["multi-sym?"](name) or {name}) local ok_3f, target = nil, nil - local function _690_() + local function _666_() return (utils["get-in"](scope.specials, path) or utils["get-in"](scope.macros, path) or resolve(name, env, scope)) end - ok_3f, target = pcall(_690_) + ok_3f, target = pcall(_666_) if ok_3f then return on_values({specials.doc(target, name)}) else return on_error("Repl", "Could not resolve value for docstring lookup") end end - return run_command(read, on_error, _689_) + return run_command(read, on_error, _665_) end do end (compiler.metadata):set(commands.doc, "fnl/docstring", "Print the docstring and arglist for a function, macro, or special form.") commands.compile = function(env, read, on_values, on_error, scope) - local function _692_(_241) + local function _668_(_241) local allowedGlobals = specials["current-global-names"](env) - local ok_3f, result = pcall(compiler.compile, _241, {env = env, scope = scope, allowedGlobals = allowedGlobals}) + local ok_3f, result = pcall(compiler.compile, _241, {allowedGlobals = allowedGlobals, env = env, scope = scope}) if ok_3f then return on_values({result}) else return on_error("Repl", ("Error compiling expression: " .. result)) end end - return run_command(read, on_error, _692_) + return run_command(read, on_error, _668_) end do end (compiler.metadata):set(commands.compile, "fnl/docstring", "compiles the expression into lua and prints the result.") local function load_plugin_commands(plugins) for _, plugin in ipairs((plugins or {})) do for name, f in pairs(plugin) do - local _694_ = name:match("^repl%-command%-(.*)") - if (nil ~= _694_) then - local cmd_name = _694_ + local _670_0 = name:match("^repl%-command%-(.*)") + if (nil ~= _670_0) then + local cmd_name = _670_0 commands[cmd_name] = (commands[cmd_name] or f) - else end end end @@ -698,50 +694,29 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars) local command_name = input:match(",([^%s/]+)") do - local _696_ = commands[command_name] - if (nil ~= _696_) then - local command = _696_ + local _672_0 = commands[command_name] + if (nil ~= _672_0) then + local command = _672_0 command(env, read, on_values, on_error, scope, chars) - elseif true then - local _ = _696_ + else + local _ = _672_0 if ("exit" ~= command_name) then on_values({"Unknown command", command_name}) - else end - else end end if ("exit" ~= command_name) then return loop() - else - return nil end end local function try_readline_21(opts, ok, readline) if ok then if readline.set_readline_name then readline.set_readline_name("fennel") - else - end - do - local rl_opts - do - local tbl_11_auto = {keeplines = 1000, histfile = ""} - for k, v in pairs(readline.set_options({})) do - local _701_, _702_ = k, v - if ((nil ~= _701_) and (nil ~= _702_)) then - local k_12_auto = _701_ - local v_13_auto = _702_ - tbl_11_auto[k_12_auto] = v_13_auto - else - end - end - rl_opts = tbl_11_auto - end - readline.set_options(rl_opts) end + readline.set_options({histfile = "", keeplines = 1000}) opts.readChunk = function(parser_state) - local prompt + local prompt = nil if (0 < parser_state["stack-size"]) then prompt = ".. " else @@ -750,8 +725,6 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local str = readline.readline(prompt) if str then return (str .. "\n") - else - return nil end end local completer0 = nil @@ -769,8 +742,6 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end readline.set_complete_function(repl_completer) return readline - else - return nil end end local function should_use_readline_3f(opts) @@ -778,8 +749,19 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end local function repl(_3foptions) local old_root_options = utils.root.options - local opts = ((_3foptions and utils.copy(_3foptions)) or {}) + local _681_ = utils.copy(_3foptions) + local opts = _681_ + local _3ffennelrc = _681_["fennelrc"] + local _ = nil + opts.fennelrc = nil + _ = nil local readline = (should_use_readline_3f(opts) and try_readline_21(opts, pcall(require, "readline"))) + local _0 = nil + if _3ffennelrc then + _0 = _3ffennelrc() + else + _0 = nil + end local env = specials["wrap-env"]((opts.env or rawget(_G, "_ENV") or _G)) local save_locals_3f = (opts.saveLocals ~= false) local read_chunk = (opts.readChunk or default_read_chunk) @@ -789,41 +771,35 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local byte_stream, clear_stream = parser.granulate(read_chunk) local chars = {} local read, reset = nil, nil - local function _708_(parser_state) + local function _683_(parser_state) local c = byte_stream(parser_state) table.insert(chars, c) return c end - read, reset = parser.parser(_708_) + read, reset = parser.parser(_683_) opts.env, opts.scope = env, compiler["make-scope"]() opts.useMetadata = (opts.useMetadata ~= false) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](env) - else end if opts.registerCompleter then - local function _712_() - local _710_ = env - local _711_ = opts.scope - local function _713_(...) - return completer(_710_, _711_, ...) + local function _686_() + local _685_0 = opts.scope + local function _687_(...) + return completer(env, _685_0, ...) end - return _713_ + return _687_ end - opts.registerCompleter(_712_()) - else + opts.registerCompleter(_686_()) end load_plugin_commands(opts.plugins) if save_locals_3f then local function newindex(t, k, v) if opts.scope.unmanglings[k] then return rawset(t, k, v) - else - return nil end end env.___replLocals___ = setmetatable({}, {__newindex = newindex}) - else end local function print_values(...) local vals = {...} @@ -839,8 +815,10 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) chars[k] = nil end reset() - local ok, not_eof_3f, x = pcall(read) + local ok, parser_not_eof_3f, x = pcall(read) local src_string = string.char(unpack(chars)) + local readline_not_eof_3f = (not readline or (src_string ~= "(null)")) + local not_eof_3f = (readline_not_eof_3f and parser_not_eof_3f) if not ok then on_error("Parse", not_eof_3f) clear_stream() @@ -850,60 +828,50 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) else if not_eof_3f then do - local _717_, _718_ = nil, nil - local function _720_() - local _719_ = opts - _719_["source"] = src_string - return _719_ + local _691_0, _692_0 = nil, nil + local function _693_() + opts["source"] = src_string + return opts end - _717_, _718_ = pcall(compiler.compile, x, _720_()) - if ((_717_ == false) and (nil ~= _718_)) then - local msg = _718_ + _691_0, _692_0 = pcall(compiler.compile, x, _693_()) + if ((_691_0 == false) and (nil ~= _692_0)) then + local msg = _692_0 clear_stream() on_error("Compile", msg) - elseif ((_717_ == true) and (nil ~= _718_)) then - local src = _718_ - local src0 + elseif ((_691_0 == true) and (nil ~= _692_0)) then + local src = _692_0 + local src0 = nil if save_locals_3f then src0 = splice_save_locals(env, src, opts.scope) else src0 = src end - local _722_, _723_ = pcall(specials["load-code"], src0, env) - if ((_722_ == false) and (nil ~= _723_)) then - local msg = _723_ + local _695_0, _696_0 = pcall(specials["load-code"], src0, env) + if ((_695_0 == false) and (nil ~= _696_0)) then + local msg = _696_0 clear_stream() on_error("Lua Compile", msg, src0) - elseif (true and (nil ~= _723_)) then - local _ = _722_ - local chunk = _723_ - local function _724_() + elseif (true and (nil ~= _696_0)) then + local _1 = _695_0 + local chunk = _696_0 + local function _697_() return print_values(chunk()) end - local function _725_() - local function _726_(...) - return on_error("Runtime", ...) - end - return _726_ + local function _698_(...) + return on_error("Runtime", ...) end - xpcall(_724_, _725_()) - else + xpcall(_697_, _698_) end - else end end utils.root.options = old_root_options return loop() - else - return nil end end end loop() if readline then return readline.save_history() - else - return nil end end return repl @@ -916,14 +884,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local unpack = (table.unpack or _G.unpack) local SPECIALS = compiler.scopes.global.specials local function wrap_env(env) - local function _416_(_, key) + local function _407_(_, key) if utils["string?"](key) then return env[compiler["global-unmangling"](key)] else return env[key] end end - local function _418_(_, key, value) + local function _409_(_, key, value) if utils["string?"](key) then env[compiler["global-unmangling"](key)] = value return nil @@ -932,60 +900,54 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return nil end end - local function _420_() + local function _411_() local function putenv(k, v) - local _421_ + local _412_ if utils["string?"](k) then - _421_ = compiler["global-unmangling"](k) + _412_ = compiler["global-unmangling"](k) else - _421_ = k + _412_ = k end - return _421_, v + return _412_, v end return next, utils.kvmap(env, putenv), nil end - return setmetatable({}, {__index = _416_, __newindex = _418_, __pairs = _420_}) + return setmetatable({}, {__index = _407_, __newindex = _409_, __pairs = _411_}) end local function current_global_names(_3fenv) - local mt + local mt = nil do - local _423_ = getmetatable(_3fenv) - if ((_G.type(_423_) == "table") and (nil ~= (_423_).__pairs)) then - local mtpairs = (_423_).__pairs - local tbl_11_auto = {} + local _414_0 = getmetatable(_3fenv) + if ((_G.type(_414_0) == "table") and (nil ~= _414_0.__pairs)) then + local mtpairs = _414_0.__pairs + local tbl_14_ = {} for k, v in mtpairs(_3fenv) do - local _424_, _425_ = k, v - if ((nil ~= _424_) and (nil ~= _425_)) then - local k_12_auto = _424_ - local v_13_auto = _425_ - tbl_11_auto[k_12_auto] = v_13_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - mt = tbl_11_auto - elseif (_423_ == nil) then + mt = tbl_14_ + elseif (_414_0 == nil) then mt = (_3fenv or _G) else - mt = nil + mt = nil end end return (mt and utils.kvmap(mt, compiler["global-unmangling"])) end local function load_code(code, _3fenv, _3ffilename) local env = (_3fenv or rawget(_G, "_ENV") or _G) - local _428_, _429_ = rawget(_G, "setfenv"), rawget(_G, "loadstring") - if ((nil ~= _428_) and (nil ~= _429_)) then - local setfenv = _428_ - local loadstring = _429_ + local _417_0, _418_0 = rawget(_G, "setfenv"), rawget(_G, "loadstring") + if ((nil ~= _417_0) and (nil ~= _418_0)) then + local setfenv = _417_0 + local loadstring = _418_0 local f = assert(loadstring(code, _3ffilename)) - local _430_ = f - setfenv(_430_, env) - return _430_ - elseif true then - local _ = _428_ - return assert(load(code, _3ffilename, "t", env)) + setfenv(f, env) + return f else - return nil + local _ = _417_0 + return assert(load(code, _3ffilename, "t", env)) end end local function doc_2a(tgt, name) @@ -996,20 +958,20 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local mt = getmetatable(tgt) if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#"}), " ") - local _432_ + local _420_ if (0 < #arglist) then - _432_ = " " + _420_ = " " else - _432_ = "" + _420_ = "" end - return string.format("(%s%s%s)\n %s", name, _432_, arglist, docstring) + return string.format("(%s%s%s)\n %s", name, _420_, arglist, docstring) else return string.format("%s\n %s", name, docstring) end end end local function doc_special(name, arglist, docstring, body_form_3f) - compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/docstring"] = docstring, ["fnl/body-form?"] = body_form_3f} + compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/body-form?"] = body_form_3f, ["fnl/docstring"] = docstring} return nil end local function compile_do(ast, scope, parent, _3fstart) @@ -1038,7 +1000,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local subexprs = compiler.compile1(ast[i], sub_scope, chunk, subopts) if (i ~= len) then compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) - else end end end @@ -1053,8 +1014,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct elseif opts.nval then local syms = {} for i = 1, opts.nval do - local s = ((_3fpre_syms and (_3fpre_syms)[i]) or compiler.gensym(scope)) - do end (syms)[i] = s + local s = ((_3fpre_syms and _3fpre_syms[i]) or compiler.gensym(scope)) + syms[i] = s retexprs[i] = utils.expr(s, "sym") end local outer_target = table.concat(syms, ", ") @@ -1063,7 +1024,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compile_body(outer_target, opts.tail) else local fname = compiler.gensym(scope) - local fargs + local fargs = nil if scope.vararg then fargs = "..." else @@ -1084,97 +1045,91 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct for j = 2, #subexprs do table.insert(exprs, subexprs[j]) end - else end end return exprs end doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.") - local function deep_tostring(x, key_3f) - if utils["list?"](x) then - local _441_ - do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for _, v in ipairs(x) do - local val_16_auto = deep_tostring(v) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else - end - end - _441_ = tbl_14_auto - end - return ("(" .. table.concat(_441_, " ") .. ")") - elseif utils["sequence?"](x) then - local _443_ - do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for _, v in ipairs(x) do - local val_16_auto = deep_tostring(v) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else - end - end - _443_ = tbl_14_auto - end - return ("[" .. table.concat(_443_, " ") .. "]") - elseif utils["table?"](x) then - local _445_ - do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for k, v in utils.stablepairs(x) do - local val_16_auto = (deep_tostring(k, true) .. " " .. deep_tostring(v)) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else - end - end - _445_ = tbl_14_auto - end - return ("{" .. table.concat(_445_, " ") .. "}") - elseif (key_3f and utils["string?"](x) and x:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then - return (":" .. x) - elseif utils["string?"](x) then - return string.format("%q", x):gsub("\\\"", "\\\\\""):gsub("\"", "\\\"") - else - return tostring(x) + local function __3estack(stack, tbl) + for k, v in pairs(tbl) do + table.insert(stack, k) + table.insert(stack, v) end + return stack end - local function set_fn_metadata(arg_list, docstring, parent, fn_name) - if utils.root.options.useMetadata then - local args - local function _448_(_241) - return ("\"%s\""):format(deep_tostring(_241)) + local function literal_3f(val) + local res = true + if utils["list?"](val) then + res = false + elseif utils["table?"](val) then + local stack = __3estack({}, val) + for _, elt in ipairs(stack) do + if not res then break end + if utils["list?"](elt) then + res = false + elseif utils["table?"](elt) then + __3estack(stack, elt) + end end - args = utils.map(arg_list, _448_) - local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")} - if docstring then - table.insert(meta_fields, "\"fnl/docstring\"") - table.insert(meta_fields, ("\"" .. docstring:gsub("%s+$", ""):gsub("\\", "\\\\"):gsub("\n", "\\n"):gsub("\"", "\\\"") .. "\"")) + end + return res + end + local function compile_value(v) + local opts = {nval = 1, tail = false} + local scope = compiler["make-scope"]() + local chunk = {} + local _431_ = compiler.compile1(v, scope, chunk, opts) + local _432_ = _431_[1] + local v0 = _432_[1] + return v0 + end + local function insert_meta(meta, k, v) + local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true} + compiler.assert((type(k) == "string"), ("expected string keys in metadata table, got: %s"):format(view(k, view_opts))) + compiler.assert(literal_3f(v), ("expected literal value in metadata table, got: %s %s"):format(view(k, view_opts), view(v, view_opts))) + table.insert(meta, view(k)) + local function _433_() + if ("string" == type(v)) then + return view(v, view_opts) else + return compile_value(v) + end + end + table.insert(meta, _433_()) + return meta + end + local function insert_arglist(meta, arg_list) + local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true} + table.insert(meta, "\"fnl/arglist\"") + local function _434_(_241) + return view(view(_241, view_opts)) + end + table.insert(meta, ("{" .. table.concat(utils.map(arg_list, _434_), ", ") .. "}")) + return meta + end + local function set_fn_metadata(f_metadata, parent, fn_name) + if utils.root.options.useMetadata then + local meta_fields = {} + for k, v in utils.stablepairs(f_metadata) do + if (k == "fnl/arglist") then + insert_arglist(meta_fields, v) + else + insert_meta(meta_fields, k, v) + end end local meta_str = ("require(\"%s\").metadata"):format((utils.root.options.moduleName or "fennel")) return compiler.emit(parent, ("pcall(function() %s:setall(%s, %s) end)"):format(meta_str, fn_name, table.concat(meta_fields, ", "))) - else - return nil end end local function get_fn_name(ast, scope, fn_name, multi) if (fn_name and (fn_name[1] ~= "nil")) then - local _451_ + local _437_ if not multi then - _451_ = compiler["declare-local"](fn_name, {}, scope, ast) + _437_ = compiler["declare-local"](fn_name, {}, scope, ast) else - _451_ = (compiler["symbol-to-expression"](fn_name, scope))[1] + _437_ = compiler["symbol-to-expression"](fn_name, scope)[1] end - return _451_, not multi, 3 + return _437_, not multi, 3 else return nil, true, 2 end @@ -1184,16 +1139,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct for i = (index + 1), #ast do compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)}) end - local _454_ + local _440_ if local_3f then - _454_ = "local function %s(%s)" + _440_ = "local function %s(%s)" else - _454_ = "%s = function(%s)" + _440_ = "%s = function(%s)" end - compiler.emit(parent, string.format(_454_, fn_name, table.concat(arg_name_list, ", ")), ast) + compiler.emit(parent, string.format(_440_, fn_name, table.concat(arg_name_list, ", ")), ast) compiler.emit(parent, f_chunk, ast) compiler.emit(parent, "end", ast) - set_fn_metadata(f_metadata["fnl/arglist"], f_metadata["fnl/docstring"], parent, fn_name) + set_fn_metadata(f_metadata, parent, fn_name) utils.hook("fn", ast, f_scope) return utils.expr(fn_name, "sym") end @@ -1201,44 +1156,52 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local fn_name = compiler.gensym(scope) return compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, true, arg_name_list, f_metadata) end + local function assoc_table_3f(t) + local len = #t + local nxt, t0, k = pairs(t) + local function _442_() + if (len == 0) then + return k + else + return len + end + end + return (nil ~= nxt(t0, _442_())) + end local function get_function_metadata(ast, arg_list, index) local f_metadata = {["fnl/arglist"] = arg_list} local index_2a = (index + 1) local expr = ast[index_2a] if (utils["string?"](expr) and (index_2a < #ast)) then - local _457_ + local _443_ do - local _456_ = f_metadata - _456_["fnl/docstring"] = expr - _457_ = _456_ + f_metadata["fnl/docstring"] = expr + _443_ = f_metadata end - return _457_, index_2a - elseif (utils["table?"](expr) and (index_2a < #ast)) then - local _458_ + return _443_, index_2a + elseif (utils["table?"](expr) and (index_2a < #ast) and assoc_table_3f(expr)) then + local _444_ do - local tbl_11_auto = f_metadata + local tbl_14_ = f_metadata for k, v in pairs(expr) do - local _459_, _460_ = k, v - if ((nil ~= _459_) and (nil ~= _460_)) then - local k_12_auto = _459_ - local v_13_auto = _460_ - tbl_11_auto[k_12_auto] = v_13_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _458_ = tbl_11_auto + _444_ = tbl_14_ end - return _458_, index_2a + return _444_, index_2a else return f_metadata, index end end SPECIALS.fn = function(ast, scope, parent) - local f_scope + local f_scope = nil do - local _463_ = compiler["make-scope"](scope) - do end (_463_)["vararg"] = false - f_scope = _463_ + local _447_0 = compiler["make-scope"](scope) + _447_0["vararg"] = false + f_scope = _447_0 end local f_chunk = {} local fn_sym = utils["sym?"](ast[2]) @@ -1246,23 +1209,48 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local fn_name, local_3f, index = get_fn_name(ast, scope, fn_sym, multi) local arg_list = compiler.assert(utils["table?"](ast[index]), "expected parameters table", ast) compiler.assert((not multi or not multi["multi-sym-method-call"]), ("unexpected multi symbol " .. tostring(fn_name)), fn_sym) - local function get_arg_name(arg) - if utils["varg?"](arg) then + local function destructure_arg(arg) + local raw = utils.sym(compiler.gensym(scope)) + local declared = compiler["declare-local"](raw, {}, f_scope, ast) + compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) + return declared + end + local function destructure_amp(i) + compiler.assert((i == (#arg_list - 1)), "expected rest argument before last parameter", arg_list[(i + 1)], arg_list) + f_scope.vararg = true + compiler.destructure(arg_list[#arg_list], {utils.varg()}, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) + return "..." + end + local function get_arg_name(arg, i) + if f_scope.vararg then + return nil + elseif utils["varg?"](arg) then compiler.assert((arg == arg_list[#arg_list]), "expected vararg as last parameter", ast) f_scope.vararg = true return "..." + elseif (utils.sym("&") == arg) then + return destructure_amp(i) elseif (utils["sym?"](arg) and (tostring(arg) ~= "nil") and not utils["multi-sym?"](tostring(arg))) then return compiler["declare-local"](arg, {}, f_scope, ast) elseif utils["table?"](arg) then - local raw = utils.sym(compiler.gensym(scope)) - local declared = compiler["declare-local"](raw, {}, f_scope, ast) - compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) - return declared + return destructure_arg(arg) else return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[index]) end end - local arg_name_list = utils.map(arg_list, get_arg_name) + local arg_name_list = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i, a in ipairs(arg_list) do + local val_19_ = get_arg_name(a, i) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + arg_name_list = tbl_17_ + end local f_metadata, index0 = get_function_metadata(ast, arg_list, index) if fn_name then return compile_named_fn(ast, f_scope, f_chunk, parent, index0, fn_name, local_3f, arg_name_list, f_metadata) @@ -1273,39 +1261,36 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring or a metadata table.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.", true) SPECIALS.lua = function(ast, _, parent) compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast) - local _467_ + local _452_ do - local _466_ = utils["sym?"](ast[2]) - if (nil ~= _466_) then - _467_ = tostring(_466_) + local _451_0 = utils["sym?"](ast[2]) + if (nil ~= _451_0) then + _452_ = tostring(_451_0) else - _467_ = _466_ + _452_ = _451_0 end end - if ("nil" ~= _467_) then + if ("nil" ~= _452_) then table.insert(parent, {ast = ast, leaf = tostring(ast[2])}) - else end - local _471_ + local _456_ do - local _470_ = utils["sym?"](ast[3]) - if (nil ~= _470_) then - _471_ = tostring(_470_) + local _455_0 = utils["sym?"](ast[3]) + if (nil ~= _455_0) then + _456_ = tostring(_455_0) else - _471_ = _470_ + _456_ = _455_0 end end - if ("nil" ~= _471_) then + if ("nil" ~= _456_) then return tostring(ast[3]) - else - return nil end end local function dot(ast, scope, parent) compiler.assert((1 < #ast), "expected table argument", ast) local len = #ast - local _let_474_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) - local lhs = _let_474_[1] + local _459_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local lhs = _459_[1] if (len == 2) then return tostring(lhs) else @@ -1315,8 +1300,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (utils["string?"](index) and utils["valid-lua-identifier?"](index)) then table.insert(indices, ("." .. index)) else - local _let_475_ = compiler.compile1(index, scope, parent, {nval = 1}) - local index0 = _let_475_[1] + local _460_ = compiler.compile1(index, scope, parent, {nval = 1}) + local index0 = _460_[1] table.insert(indices, ("[" .. tostring(index0) .. "]")) end end @@ -1361,26 +1346,25 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end doc_special("var", {"name", "val"}, "Introduce new mutable local.") local function kv_3f(t) - local _479_ + local _464_ do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for k in pairs(t) do - local val_16_auto + local val_19_ = nil if ("number" ~= type(k)) then - val_16_auto = k + val_19_ = k else - val_16_auto = nil + val_19_ = nil end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _479_ = tbl_14_auto + _464_ = tbl_17_ end - return (_479_)[1] + return _464_[1] end SPECIALS.let = function(ast, scope, parent, opts) local bindings = ast[2] @@ -1407,29 +1391,27 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end local function disambiguate_3f(rootstr, parent) - local function _484_() - local _483_ = get_prev_line(parent) - if (nil ~= _483_) then - local prev_line = _483_ + local function _469_() + local _468_0 = get_prev_line(parent) + if (nil ~= _468_0) then + local prev_line = _468_0 return prev_line:match("%)$") - else - return nil end end - return (rootstr:match("^{") or _484_()) + return (rootstr:match("^{") or _469_()) end SPECIALS.tset = function(ast, scope, parent) compiler.assert((3 < #ast), "expected table, key, and value arguments", ast) - local root = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] + local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] local keys = {} for i = 3, (#ast - 1) do - local _let_486_ = compiler.compile1(ast[i], scope, parent, {nval = 1}) - local key = _let_486_[1] + local _471_ = compiler.compile1(ast[i], scope, parent, {nval = 1}) + local key = _471_[1] table.insert(keys, tostring(key)) end - local value = (compiler.compile1(ast[#ast], scope, parent, {nval = 1}))[1] + local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1] local rootstr = tostring(root) - local fmtstr + local fmtstr = nil if disambiguate_3f(rootstr, parent) then fmtstr = "do end (%s)[%s] = %s" else @@ -1446,7 +1428,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local target_exprs = {} for i = 1, opts.nval do local s = compiler.gensym(scope) - do end (accum)[i] = s + accum[i] = s target_exprs[i] = utils.expr(s, "sym") end return "target", opts.tail, table.concat(accum, ", "), target_exprs @@ -1468,7 +1450,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end if (1 == (#ast % 2)) then table.insert(ast, utils.sym("nil")) - else end for i = 2, (#ast - 1), 2 do local condchunk = {} @@ -1486,7 +1467,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local last_buffer = buffer for i = 1, #branches do local branch = branches[i] - local fstr + local fstr = nil if not branch.nested then fstr = "if %s then" else @@ -1507,13 +1488,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.emit(last_buffer, "else", ast) compiler.emit(last_buffer, else_branch.chunk, ast) compiler.emit(last_buffer, "end", ast) - elseif not (branches[(i + 1)]).nested then + elseif not branches[(i + 1)].nested then local next_buffer = {} compiler.emit(last_buffer, "else", ast) compiler.emit(last_buffer, next_buffer, ast) compiler.emit(last_buffer, "end", ast) last_buffer = next_buffer - else end end if (wrapper == "iife") then @@ -1542,17 +1522,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if ((utils["sym?"](last_item) and (tostring(last_item) == "&until")) or ("until" == last_item)) then table.remove(bindings, (#bindings - 1)) return table.remove(bindings) - else - return nil end end local function compile_until(condition, scope, chunk) if condition then - local _let_495_ = compiler.compile1(condition, scope, chunk, {nval = 1}) - local condition_lua = _let_495_[1] + local _480_ = compiler.compile1(condition, scope, chunk, {nval = 1}) + local condition_lua = _480_[1] return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(condition, "expression")) - else - return nil end end SPECIALS.each = function(ast, scope, parent) @@ -1570,7 +1546,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compiler["declare-local"](v, {}, sub_scope, ast, new_manglings) else local raw = utils.sym(compiler.gensym(sub_scope)) - do end (destructures)[raw] = v + destructures[raw] = v return compiler["declare-local"](raw, {}, sub_scope, ast) end end @@ -1591,13 +1567,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("each", {"[key value (iterator)]", "..."}, "Runs the body once for each set of values provided by the given iterator.\nMost commonly used with ipairs for sequential tables or pairs for undefined\norder, but can be used with any iterator.", true) local function while_2a(ast, scope, parent) local len1 = #parent - local condition = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] + local condition = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] local len2 = #parent local sub_chunk = {} if (len1 ~= len2) then for i = (len1 + 1), len2 do table.insert(sub_chunk, parent[i]) - do end (parent)[i] = nil + parent[i] = nil end compiler.emit(parent, "while true do", ast) compiler.emit(sub_chunk, ("if not %s then break end"):format(condition[1]), ast) @@ -1621,7 +1597,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.assert((3 <= #ast), "expected body expression", ast[1]) compiler.assert((#ranges <= 3), "unexpected arguments", ranges[4]) for i = 1, math.min(#ranges, 3) do - range_args[i] = tostring((compiler.compile1(ranges[i], scope, parent, {nval = 1}))[1]) + range_args[i] = tostring(compiler.compile1(ranges[i], scope, parent, {nval = 1})[1]) end compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast) compile_until(until_condition, sub_scope, chunk) @@ -1632,11 +1608,11 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct SPECIALS["for"] = for_2a doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).", true) local function native_method_call(ast, _scope, _parent, target, args) - local _let_499_ = ast - local _ = _let_499_[1] - local _0 = _let_499_[2] - local method_string = _let_499_[3] - local call_string + local _484_ = ast + local _ = _484_[1] + local _0 = _484_[2] + local method_string = _484_[3] + local call_string = nil if ((target.type == "literal") or (target.type == "varg") or (target.type == "expression")) then call_string = "(%s):%s(%s)" else @@ -1645,30 +1621,30 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return utils.expr(string.format(call_string, tostring(target), method_string, table.concat(args, ", ")), "statement") end local function nonnative_method_call(ast, scope, parent, target, args) - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) + local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1]) local args0 = {tostring(target), unpack(args)} return utils.expr(string.format("%s[%s](%s)", tostring(target), method_string, table.concat(args0, ", ")), "statement") end local function double_eval_protected_method_call(ast, scope, parent, target, args) - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) + local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1]) local call = "(function(tgt, m, ...) return tgt[m](tgt, ...) end)(%s, %s)" table.insert(args, 1, method_string) return utils.expr(string.format(call, tostring(target), table.concat(args, ", ")), "statement") end local function method_call(ast, scope, parent) compiler.assert((2 < #ast), "expected at least 2 arguments", ast) - local _let_501_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) - local target = _let_501_[1] + local _486_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local target = _486_[1] local args = {} for i = 4, #ast do - local subexprs - local _502_ + local subexprs = nil + local _487_ if (i ~= #ast) then - _502_ = 1 + _487_ = 1 else - _502_ = nil + _487_ = nil end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _502_}) + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _487_}) utils.map(subexprs, tostring, args) end if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then @@ -1690,7 +1666,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.", true) local function hashfn_max_used(f_scope, i, max) - local max0 + local max0 = nil if f_scope.symmeta[("$" .. i)].used then max0 = i else @@ -1704,12 +1680,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end SPECIALS.hashfn = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) - local f_scope + local f_scope = nil do - local _507_ = compiler["make-scope"](scope) - do end (_507_)["vararg"] = false - _507_["hashfn"] = true - f_scope = _507_ + local _492_0 = compiler["make-scope"](scope) + _492_0["vararg"] = false + _492_0["hashfn"] = true + f_scope = _492_0 end local f_chunk = {} local name = compiler.gensym(scope) @@ -1725,7 +1701,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct f_scope.vararg = true return nil else - return (utils["list?"](node) or utils["table?"](node)) + return (("table" == type(node)) and (utils.sym("hashfn") ~= node[1]) and (utils["list?"](node) or utils["table?"](node))) end end utils["walk-tree"](ast[2], walker) @@ -1733,9 +1709,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local max_used = hashfn_max_used(f_scope, 1, 0) if f_scope.vararg then compiler.assert((max_used == 0), "$ and $... in hashfn are mutually exclusive", ast) - else end - local arg_str + local arg_str = nil if f_scope.vararg then arg_str = tostring(utils.varg()) else @@ -1747,9 +1722,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return utils.expr(name, "sym") end doc_special("hashfn", {"..."}, "Function literal shorthand; args are either $... OR $1, $2, etc.") - local function maybe_short_circuit_protect(ast, i, name, _511_) - local _arg_512_ = _511_ - local mac = _arg_512_["macros"] + local function maybe_short_circuit_protect(ast, i, name, _496_0) + local _497_ = _496_0 + local mac = _497_["macros"] local call = (utils["list?"](ast) and tostring(ast[1])) if ((("or" == name) or ("and" == name)) and (1 < i) and (mac[call] or ("set" == call) or ("tset" == call) or ("global" == call))) then return utils.list(utils.sym("do"), ast) @@ -1770,40 +1745,35 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct table.insert(operands, tostring(subexprs[1])) end end - local _515_ = #operands - if (_515_ == 0) then - local _517_ + local _500_0 = #operands + if (_500_0 == 0) then + local _501_ do - local _516_ = zero_arity - compiler.assert(_516_, "Expected more than 0 arguments", ast) - _517_ = _516_ + compiler.assert(zero_arity, "Expected more than 0 arguments", ast) + _501_ = zero_arity end - return utils.expr(_517_, "literal") - elseif (_515_ == 1) then + return utils.expr(_501_, "literal") + elseif (_500_0 == 1) then if unary_prefix then return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")") else return operands[1] end - elseif true then - local _ = _515_ - return ("(" .. table.concat(operands, padded_op) .. ")") else - return nil + local _ = _500_0 + return ("(" .. table.concat(operands, padded_op) .. ")") end end local function define_arithmetic_special(name, zero_arity, unary_prefix, _3flua_name) - local _523_ + local _505_ do - local _520_ = (_3flua_name or name) - local _521_ = zero_arity - local _522_ = unary_prefix - local function _524_(...) - return arithmetic_special(_520_, _521_, _522_, ...) + local _504_0 = (_3flua_name or name) + local function _506_(...) + return arithmetic_special(_504_0, zero_arity, unary_prefix, ...) end - _523_ = _524_ + _505_ = _506_ end - SPECIALS[name] = _523_ + SPECIALS[name] = _505_ return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.") end define_arithmetic_special("+", "0") @@ -1831,14 +1801,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local padded_native_name = (" " .. native_name .. " ") local prefixed_lib_name = ("bit." .. lib_name) for i = 2, len do - local subexprs - local _525_ + local subexprs = nil + local _507_ if (i ~= len) then - _525_ = 1 + _507_ = 1 else - _525_ = nil + _507_ = nil end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _525_}) + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _507_}) utils.map(subexprs, tostring, operands) end if (#operands == 1) then @@ -1857,18 +1827,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end local function define_bitop_special(name, zero_arity, unary_prefix, native) - local _535_ - do - local _531_ = native - local _532_ = name - local _533_ = zero_arity - local _534_ = unary_prefix - local function _536_(...) - return bitop_special(_531_, _532_, _533_, _534_, ...) - end - _535_ = _536_ + local function _513_(...) + return bitop_special(native, name, zero_arity, unary_prefix, ...) end - SPECIALS[name] = _535_ + SPECIALS[name] = _513_ return nil end define_bitop_special("lshift", nil, "1", "<<") @@ -1882,17 +1844,47 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("bor", {"x1", "x2", "..."}, "Bitwise OR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") doc_special("bxor", {"x1", "x2", "..."}, "Bitwise XOR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.") - local function native_comparator(op, _537_, scope, parent) - local _arg_538_ = _537_ - local _ = _arg_538_[1] - local lhs_ast = _arg_538_[2] - local rhs_ast = _arg_538_[3] - local _let_539_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) - local lhs = _let_539_[1] - local _let_540_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) - local rhs = _let_540_[1] + local function native_comparator(op, _514_0, scope, parent) + local _515_ = _514_0 + local _ = _515_[1] + local lhs_ast = _515_[2] + local rhs_ast = _515_[3] + local _516_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) + local lhs = _516_[1] + local _517_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) + local rhs = _517_[1] return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs)) end + local function idempotent_comparator(op, chain_op, ast, scope, parent) + local vals = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 2, #ast do + local val_19_ = tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + vals = tbl_17_ + end + local comparisons = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 1, (#vals - 1) do + local val_19_ = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + comparisons = tbl_17_ + end + local chain = string.format(" %s ", (chain_op or "and")) + return table.concat(comparisons, chain) + end local function double_eval_protected_comparator(op, chain_op, ast, scope, parent) local arglist = {} local comparisons = {} @@ -1900,10 +1892,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local chain = string.format(" %s ", (chain_op or "and")) for i = 2, #ast do table.insert(arglist, tostring(compiler.gensym(scope))) - table.insert(vals, tostring((compiler.compile1(ast[i], scope, parent, {nval = 1}))[1])) + table.insert(vals, tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1])) end - for i = 1, (#arglist - 1) do - table.insert(comparisons, string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)])) + do + local tbl_17_ = comparisons + local i_18_ = #tbl_17_ + for i = 1, (#arglist - 1) do + local val_19_ = string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end end return string.format("(function(%s) return %s end)(%s)", table.concat(arglist, ","), table.concat(comparisons, chain), table.concat(vals, ",")) end @@ -1914,6 +1914,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.assert((2 < #ast), "expected at least two arguments", ast) if (3 == #ast) then return native_comparator(op, ast, scope, parent) + elseif utils["every?"]({unpack(ast, 2)}, utils["idempotent-expr?"]) then + return idempotent_comparator(op, _3fchain_op, ast, scope, parent) else return double_eval_protected_comparator(op, _3fchain_op, ast, scope, parent) end @@ -1943,7 +1945,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") define_unary_special("length", "#") doc_special("length", {"x"}, "Returns the length of a table or string.") - do end (SPECIALS)["~="] = SPECIALS["not="] + SPECIALS["~="] = SPECIALS["not="] SPECIALS["#"] = SPECIALS.length SPECIALS.quote = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) @@ -1952,7 +1954,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct this_scope = this_scope.parent if (this_scope == compiler.scopes.compiler) then runtime = false - else end end return compiler["do-quote"](ast[2], scope, parent, runtime) @@ -1966,26 +1967,25 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local safe_require = nil local function safe_compiler_env() - local _544_ + local _524_ do - local _543_ = rawget(_G, "utf8") - if (nil ~= _543_) then - _544_ = utils.copy(_543_) + local _523_0 = rawget(_G, "utf8") + if (nil ~= _523_0) then + _524_ = utils.copy(_523_0) else - _544_ = _543_ + _524_ = _523_0 end end - return {table = utils.copy(table), math = utils.copy(math), string = utils.copy(string), pairs = utils.stablepairs, ipairs = ipairs, select = select, tostring = tostring, tonumber = tonumber, bit = rawget(_G, "bit"), pcall = pcall, xpcall = xpcall, next = next, print = print, type = type, assert = assert, error = error, setmetatable = setmetatable, getmetatable = safe_getmetatable, require = safe_require, rawlen = rawget(_G, "rawlen"), rawget = rawget, rawset = rawset, rawequal = rawequal, _VERSION = _VERSION, utf8 = _544_} + return {_VERSION = _VERSION, assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = utils.stablepairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, require = safe_require, select = select, setmetatable = setmetatable, string = utils.copy(string), table = utils.copy(table), tonumber = tonumber, tostring = tostring, type = type, utf8 = _524_, xpcall = xpcall} end local function combined_mt_pairs(env) local combined = {} - local _let_546_ = getmetatable(env) - local __index = _let_546_["__index"] + local _526_ = getmetatable(env) + local __index = _526_["__index"] if ("table" == type(__index)) then for k, v in pairs(__index) do combined[k] = v end - else end for k, v in next, env, nil do combined[k] = v @@ -1993,60 +1993,57 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return next, combined, nil end local function make_compiler_env(ast, scope, parent, _3fopts) - local provided + local provided = nil do - local _548_ = (_3fopts or utils.root.options) - if ((_G.type(_548_) == "table") and ((_548_)["compiler-env"] == "strict")) then + local _528_0 = (_3fopts or utils.root.options) + if ((_G.type(_528_0) == "table") and (_528_0["compiler-env"] == "strict")) then provided = safe_compiler_env() - elseif ((_G.type(_548_) == "table") and (nil ~= (_548_).compilerEnv)) then - local compilerEnv = (_548_).compilerEnv + elseif ((_G.type(_528_0) == "table") and (nil ~= _528_0.compilerEnv)) then + local compilerEnv = _528_0.compilerEnv provided = compilerEnv - elseif ((_G.type(_548_) == "table") and (nil ~= (_548_)["compiler-env"])) then - local compiler_env = (_548_)["compiler-env"] + elseif ((_G.type(_528_0) == "table") and (nil ~= _528_0["compiler-env"])) then + local compiler_env = _528_0["compiler-env"] provided = compiler_env - elseif true then - local _ = _548_ - provided = safe_compiler_env(false) else - provided = nil + local _ = _528_0 + provided = safe_compiler_env(false) end end - local env - local function _550_(base) - return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) - end - local function _551_() + local env = nil + local function _530_() return compiler.scopes.macro end - local function _552_(symbol) + local function _531_(symbol) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.scopes.macro.manglings[tostring(symbol)] end - local function _553_(form) + local function _532_(base) + return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) + end + local function _533_(form) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.macroexpand(form, compiler.scopes.macro) end - env = {_AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), ["macro-loaded"] = macro_loaded, unpack = unpack, ["assert-compile"] = compiler.assert, view = view, version = utils.version, metadata = compiler.metadata, ["ast-source"] = utils["ast-source"], list = utils.list, ["list?"] = utils["list?"], ["table?"] = utils["table?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], comment = utils.comment, ["comment?"] = utils["comment?"], ["varg?"] = utils["varg?"], gensym = _550_, ["get-scope"] = _551_, ["in-scope?"] = _552_, macroexpand = _553_} + env = {["assert-compile"] = compiler.assert, ["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["get-scope"] = _530_, ["in-scope?"] = _531_, ["list?"] = utils["list?"], ["macro-loaded"] = macro_loaded, ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), comment = utils.comment, gensym = _532_, list = utils.list, macroexpand = _533_, metadata = compiler.metadata, sequence = utils.sequence, sym = utils.sym, unpack = unpack, version = utils.version, view = view} env._G = env return setmetatable(env, {__index = provided, __newindex = provided, __pairs = combined_mt_pairs}) end - local function _555_(...) - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local function _534_(...) + local tbl_17_ = {} + local i_18_ = #tbl_17_ for c in string.gmatch((package.config or ""), "([^\n]+)") do - local val_16_auto = c - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = c + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_14_auto + return tbl_17_ end - local _local_554_ = _555_(...) - local dirsep = _local_554_[1] - local pathsep = _local_554_[2] - local pathmark = _local_554_[3] + local _536_ = _534_(...) + local dirsep = _536_[1] + local pathsep = _536_[2] + local pathmark = _536_[3] local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or ";"), pathsep = (pathsep or "?")} local function escapepat(str) return string.gsub(str, "[^%w]", "%%%1") @@ -2059,40 +2056,36 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function try_path(path) local filename = path:gsub(escapepat(pkg_config.pathmark), no_dot_module) local filename2 = path:gsub(escapepat(pkg_config.pathmark), modulename) - local _557_ = (io.open(filename) or io.open(filename2)) - if (nil ~= _557_) then - local file = _557_ + local _537_0 = (io.open(filename) or io.open(filename2)) + if (nil ~= _537_0) then + local file = _537_0 file:close() return filename - elseif true then - local _ = _557_ - return nil, ("no file '" .. filename .. "'") else - return nil + local _ = _537_0 + return nil, ("no file '" .. filename .. "'") end end local function find_in_path(start, _3ftried_paths) - local _559_ = fullpath:match(pattern, start) - if (nil ~= _559_) then - local path = _559_ - local _560_, _561_ = try_path(path) - if (nil ~= _560_) then - local filename = _560_ + local _539_0 = fullpath:match(pattern, start) + if (nil ~= _539_0) then + local path = _539_0 + local _540_0, _541_0 = try_path(path) + if (nil ~= _540_0) then + local filename = _540_0 return filename - elseif ((_560_ == nil) and (nil ~= _561_)) then - local error = _561_ - local function _563_() - local _562_ = (_3ftried_paths or {}) - table.insert(_562_, error) - return _562_ + elseif ((_540_0 == nil) and (nil ~= _541_0)) then + local error = _541_0 + local function _543_() + local _542_0 = (_3ftried_paths or {}) + table.insert(_542_0, error) + return _542_0 end - return find_in_path((start + #path + 1), _563_()) - else - return nil + return find_in_path((start + #path + 1), _543_()) end - elseif true then - local _ = _559_ - local function _565_() + else + local _ = _539_0 + local function _545_() local tried_paths = table.concat((_3ftried_paths or {}), "\n\9") if (_VERSION < "Lua 5.4") then return ("\n\9" .. tried_paths) @@ -2100,41 +2093,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return tried_paths end end - return nil, _565_() - else - return nil + return nil, _545_() end end return find_in_path(1) end local function make_searcher(_3foptions) - local function _568_(module_name) + local function _548_(module_name) local opts = utils.copy(utils.root.options) for k, v in pairs((_3foptions or {})) do opts[k] = v end opts["module-name"] = module_name - local _569_, _570_ = search_module(module_name) - if (nil ~= _569_) then - local filename = _569_ - local _573_ - do - local _571_ = filename - local _572_ = opts - local function _574_(...) - return utils["fennel-module"].dofile(_571_, _572_, ...) - end - _573_ = _574_ + local _549_0, _550_0 = search_module(module_name) + if (nil ~= _549_0) then + local filename = _549_0 + local function _551_(...) + return utils["fennel-module"].dofile(filename, opts, ...) end - return _573_, filename - elseif ((_569_ == nil) and (nil ~= _570_)) then - local error = _570_ + return _551_, filename + elseif ((_549_0 == nil) and (nil ~= _550_0)) then + local error = _550_0 return error - else - return nil end end - return _568_ + return _548_ end local function dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) local searchers = (package.loaders or package.searchers or {}) @@ -2144,116 +2127,101 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return m end local function fennel_macro_searcher(module_name) - local opts + local opts = nil do - local _576_ = utils.copy(utils.root.options) - do end (_576_)["module-name"] = module_name - _576_["env"] = "_COMPILER" - _576_["requireAsInclude"] = false - _576_["allowedGlobals"] = nil - opts = _576_ + local _553_0 = utils.copy(utils.root.options) + _553_0["module-name"] = module_name + _553_0["env"] = "_COMPILER" + _553_0["requireAsInclude"] = false + _553_0["allowedGlobals"] = nil + opts = _553_0 end - local _577_ = search_module(module_name, utils["fennel-module"]["macro-path"]) - if (nil ~= _577_) then - local filename = _577_ - local _578_ + local _554_0 = search_module(module_name, utils["fennel-module"]["macro-path"]) + if (nil ~= _554_0) then + local filename = _554_0 + local _555_ if (opts["compiler-env"] == _G) then - local _579_ = fennel_macro_searcher - local _580_ = filename - local _581_ = opts - local function _583_(...) - return dofile_with_searcher(_579_, _580_, _581_, ...) + local function _556_(...) + return dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) end - _578_ = _583_ + _555_ = _556_ else - local _584_ = filename - local _585_ = opts - local function _587_(...) - return utils["fennel-module"].dofile(_584_, _585_, ...) + local function _557_(...) + return utils["fennel-module"].dofile(filename, opts, ...) end - _578_ = _587_ + _555_ = _557_ end - return _578_, filename - else - return nil + return _555_, filename end end local function lua_macro_searcher(module_name) - local _590_ = search_module(module_name, package.path) - if (nil ~= _590_) then - local filename = _590_ - local code + local _560_0 = search_module(module_name, package.path) + if (nil ~= _560_0) then + local filename = _560_0 + local code = nil do local f = io.open(filename) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _592_() + local function _562_() return assert(f:read("*a")) end - code = close_handlers_8_auto(_G.xpcall(_592_, (package.loaded.fennel or debug).traceback)) + code = close_handlers_10_(_G.xpcall(_562_, (package.loaded.fennel or debug).traceback)) end local chunk = load_code(code, make_compiler_env(), filename) return chunk, filename - else - return nil end end local macro_searchers = {fennel_macro_searcher, lua_macro_searcher} local function search_macro_module(modname, n) - local _594_ = macro_searchers[n] - if (nil ~= _594_) then - local f = _594_ - local _595_, _596_ = f(modname) - if ((nil ~= _595_) and true) then - local loader = _595_ - local _3ffilename = _596_ + local _564_0 = macro_searchers[n] + if (nil ~= _564_0) then + local f = _564_0 + local _565_0, _566_0 = f(modname) + if ((nil ~= _565_0) and true) then + local loader = _565_0 + local _3ffilename = _566_0 return loader, _3ffilename - elseif true then - local _ = _595_ - return search_macro_module(modname, (n + 1)) else - return nil + local _ = _565_0 + return search_macro_module(modname, (n + 1)) end - else - return nil end end local function sandbox_fennel_module(modname) if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then return {metadata = compiler.metadata, view = view} - else - return nil end end - local function _600_(modname) - local function _601_() + local function _570_(modname) + local function _571_() local loader, filename = search_macro_module(modname, 1) compiler.assert(loader, (modname .. " module not found.")) - do end (macro_loaded)[modname] = loader(modname, filename) + macro_loaded[modname] = loader(modname, filename) return macro_loaded[modname] end - return (macro_loaded[modname] or sandbox_fennel_module(modname) or _601_()) + return (macro_loaded[modname] or sandbox_fennel_module(modname) or _571_()) end - safe_require = _600_ + safe_require = _570_ local function add_macros(macros_2a, ast, scope) compiler.assert(utils["table?"](macros_2a), "expected macros to be table", ast) for k, v in pairs(macros_2a) do compiler.assert((type(v) == "function"), "expected each macro to be function", ast) compiler["check-binding-valid"](utils.sym(k), scope, ast, {["macro?"] = true}) - do end (scope.macros)[k] = v + scope.macros[k] = v end return nil end - local function resolve_module_name(_602_, _scope, _parent, opts) - local _arg_603_ = _602_ - local filename = _arg_603_["filename"] - local second = _arg_603_[2] + local function resolve_module_name(_572_0, _scope, _parent, opts) + local _573_ = _572_0 + local second = _573_[2] + local filename = _573_["filename"] local filename0 = (filename or (utils["table?"](second) and second.filename)) local module_name = utils.root.options["module-name"] local modexpr = compiler.compile(second, opts) @@ -2267,8 +2235,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if not macro_loaded[modname] then local loader, filename = search_macro_module(modname, 1) compiler.assert(loader, (modname .. " module not found."), ast) - do end (macro_loaded)[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) - else + macro_loaded[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) end if ("import-macros" == tostring(ast[1])) then return macro_loaded[modname] @@ -2282,13 +2249,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local forms = {} if utils.root.options.requireAsInclude then subscope.specials.require = compiler["require-include"] - else end for _, val in parser.parser(parser["string-stream"](src), path) do table.insert(forms, val) end for i = 1, #forms do - local subopts + local subopts = nil if (i == #forms) then subopts = {tail = true} else @@ -2301,21 +2267,21 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local function include_path(ast, opts, path, mod, fennel_3f) utils.root.scope.includes[mod] = "fnl/loading" - local src + local src = nil do local f = assert(io.open(path)) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _609_() + local function _579_() return assert(f:read("*all")):gsub("[\13\n]*$", "") end - src = close_handlers_8_auto(_G.xpcall(_609_, (package.loaded.fennel or debug).traceback)) + src = close_handlers_10_(_G.xpcall(_579_, (package.loaded.fennel or debug).traceback)) end local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") local target = ("package.preload[%q]"):format(mod) @@ -2339,23 +2305,19 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (utils.root.scope.includes[mod] == "fnl/loading") then compiler.assert(fallback, "circular include detected", ast) return fallback(modexpr) - else - return nil end end SPECIALS.include = function(ast, scope, parent, opts) compiler.assert((#ast == 2), "expected one argument", ast) - local modexpr + local modexpr = nil do - local _612_, _613_ = pcall(resolve_module_name, ast, scope, parent, opts) - if ((_612_ == true) and (nil ~= _613_)) then - local modname = _613_ + local _582_0, _583_0 = pcall(resolve_module_name, ast, scope, parent, opts) + if ((_582_0 == true) and (nil ~= _583_0)) then + local modname = _583_0 modexpr = utils.expr(string.format("%q", modname), "literal") - elseif true then - local _ = _612_ - modexpr = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] else - modexpr = nil + local _ = _582_0 + modexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] end end if ((modexpr.type ~= "literal") or ((modexpr[1]):byte() ~= 34)) then @@ -2367,17 +2329,17 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct else local mod = load_code(("return " .. modexpr[1]))() local oldmod = utils.root.options["module-name"] - local _ + local _ = nil utils.root.options["module-name"] = mod _ = nil - local res - local function _617_() - local _616_ = search_module(mod) - if (nil ~= _616_) then - local fennel_path = _616_ + local res = nil + local function _587_() + local _586_0 = search_module(mod) + if (nil ~= _586_0) then + local fennel_path = _586_0 return include_path(ast, opts, fennel_path, mod, true) - elseif true then - local _0 = _616_ + else + local _0 = _586_0 local lua_path = search_module(mod, package.path) if lua_path then return include_path(ast, opts, lua_path, mod, false) @@ -2386,11 +2348,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct else return compiler.assert(false, ("module not found " .. mod), ast) end - else - return nil end end - res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _617_()) + res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _587_()) utils.root.options["module-name"] = oldmod return res end @@ -2401,10 +2361,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local opts = utils.copy(utils.root.options) opts.scope = compiler["make-scope"](compiler.scopes.compiler) opts.allowedGlobals = current_global_names(env) - return load_code(compiler.compile(ast, opts), wrap_env(env))(opts["module-name"], ast.filename) + return assert(load_code(compiler.compile(ast, opts), wrap_env(env)), opts["module-name"], ast.filename)() end SPECIALS.macros = function(ast, scope, parent) - compiler.assert((#ast == 2), "Expected one table argument", ast) + compiler.assert(((#ast == 2) and utils["table?"](ast[2])), "Expected one table argument", ast) return add_macros(eval_compiler_2a(ast[2], scope, parent), ast, scope, parent) end doc_special("macros", {"{:macro-name-1 (fn [...] ...) ... :macro-name-N macro-body-N}"}, "Define all functions in the given table as macros local to the current scope.") @@ -2412,11 +2372,11 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local old_first = ast[1] ast[1] = utils.sym("do") local val = eval_compiler_2a(ast, scope, parent) - do end (ast)[1] = old_first + ast[1] = old_first return val end doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.", true) - return {doc = doc_2a, ["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env, ["search-module"] = search_module, ["make-searcher"] = make_searcher, ["wrap-env"] = wrap_env} + return {["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env, ["make-searcher"] = make_searcher, ["search-module"] = search_module, ["wrap-env"] = wrap_env, doc = doc_2a} end package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or function(...) local utils = require("fennel.utils") @@ -2426,16 +2386,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local scopes = {} local function make_scope(_3fparent) local parent = (_3fparent or scopes.global) - local _258_ + local _252_ if parent then - _258_ = ((parent.depth or 0) + 1) + _252_ = ((parent.depth or 0) + 1) else - _258_ = 0 + _252_ = 0 end - return {includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), vararg = (parent and parent.vararg), depth = _258_, hashfn = (parent and parent.hashfn), refedglobals = {}, parent = parent} + return {autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), depth = _252_, gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), hashfn = (parent and parent.hashfn), includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), parent = parent, refedglobals = {}, specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), vararg = (parent and parent.vararg)} end local function assert_msg(ast, msg) - local ast_tbl + local ast_tbl = nil if ("table" == type(ast)) then ast_tbl = ast else @@ -2448,21 +2408,26 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local target = tostring((utils["sym?"](ast_tbl[1]) or ast_tbl[1] or "()")) return string.format("%s:%s:%s Compile error in '%s': %s", filename, line, col, target, msg) end - local function assert_compile(condition, msg, ast) + local function assert_compile(condition, msg, ast, _3ffallback_ast) if not condition then - local _let_261_ = (utils.root.options or {}) - local source = _let_261_["source"] - local unfriendly = _let_261_["unfriendly"] - if (nil == utils.hook("assert-compile", condition, msg, ast, utils.root.reset)) then + local _255_ = (utils.root.options or {}) + local error_pinpoint = _255_["error-pinpoint"] + local source = _255_["source"] + local unfriendly = _255_["unfriendly"] + local ast0 = nil + if next(utils["ast-source"](ast)) then + ast0 = ast + else + ast0 = (_3ffallback_ast or {}) + end + if (nil == utils.hook("assert-compile", condition, msg, ast0, utils.root.reset)) then utils.root.reset() if (unfriendly or not friend or not _G.io or not _G.io.read) then - error(assert_msg(ast, msg), 0) + error(assert_msg(ast0, msg), 0) else - friend["assert-compile"](condition, msg, ast, source) + friend["assert-compile"](condition, msg, ast0, source, {["error-pinpoint"] = error_pinpoint}) end - else end - else end return condition end @@ -2470,38 +2435,36 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct scopes.global.vararg = true scopes.compiler = make_scope(scopes.global) scopes.macro = scopes.global - local serialize_subst = {["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n", ["\11"] = "\\v", ["\12"] = "\\f"} + local serialize_subst = {["\11"] = "\\v", ["\12"] = "\\f", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n"} local function serialize_string(str) - local function _265_(_241) + local function _260_(_241) return ("\\" .. _241:byte()) end - return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _265_) + return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _260_) end local function global_mangling(str) if utils["valid-lua-identifier?"](str) then return str else - local function _266_(_241) + local function _261_(_241) return string.format("_%02x", _241:byte()) end - return ("__fnl_global__" .. str:gsub("[^%w]", _266_)) + return ("__fnl_global__" .. str:gsub("[^%w]", _261_)) end end local function global_unmangling(identifier) - local _268_ = string.match(identifier, "^__fnl_global__(.*)$") - if (nil ~= _268_) then - local rest = _268_ - local _269_ - local function _270_(_241) + local _263_0 = string.match(identifier, "^__fnl_global__(.*)$") + if (nil ~= _263_0) then + local rest = _263_0 + local _264_0 = nil + local function _265_(_241) return string.char(tonumber(_241:sub(2), 16)) end - _269_ = string.gsub(rest, "_[%da-f][%da-f]", _270_) - return _269_ - elseif true then - local _ = _268_ - return identifier + _264_0 = string.gsub(rest, "_[%da-f][%da-f]", _265_) + return _264_0 else - return nil + local _ = _263_0 + return identifier end end local allowed_globals = nil @@ -2517,29 +2480,29 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function local_mangling(str, scope, ast, _3ftemp_manglings) assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast) - local raw - if ((utils["lua-keywords"])[str] or str:match("^%d")) then + local raw = nil + if (utils["lua-keywords"][str] or str:match("^%d")) then raw = ("_" .. str) else raw = str end - local mangling - local function _274_(_241) + local mangling = nil + local function _269_(_241) return string.format("_%02x", _241:byte()) end - mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _274_) + mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _269_) local unique = unique_mangling(mangling, mangling, scope, 0) - do end (scope.unmanglings)[unique] = str + scope.unmanglings[unique] = str do local manglings = (_3ftemp_manglings or scope.manglings) - do end (manglings)[str] = unique + manglings[str] = unique end return unique end local function apply_manglings(scope, new_manglings, ast) for raw, mangled in pairs(new_manglings) do assert_compile(not scope.refedglobals[mangled], ("use of global " .. raw .. " is aliased by a local"), ast) - do end (scope.manglings)[raw] = mangled + scope.manglings[raw] = mangled end return nil end @@ -2568,7 +2531,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or "")) end scope.unmanglings[mangling] = (_3fbase or true) - do end (scope.gensyms)[mangling] = true + scope.gensyms[mangling] = true return mangling end local function combine_auto_gensym(parts, first) @@ -2580,35 +2543,32 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return table.concat(parts, ".") end local function autogensym(base, scope) - local _277_ = utils["multi-sym?"](base) - if (nil ~= _277_) then - local parts = _277_ + local _272_0 = utils["multi-sym?"](base) + if (nil ~= _272_0) then + local parts = _272_0 return combine_auto_gensym(parts, autogensym(parts[1], scope)) - elseif true then - local _ = _277_ - local function _278_() + else + local _ = _272_0 + local function _273_() local mangling = gensym(scope, base:sub(1, ( - 2)), "auto") - do end (scope.autogensyms)[base] = mangling + scope.autogensyms[base] = mangling return mangling end - return (scope.autogensyms[base] or _278_()) - else - return nil + return (scope.autogensyms[base] or _273_()) end end local function check_binding_valid(symbol, scope, ast, _3fopts) local name = tostring(symbol) - local macro_3f + local macro_3f = nil do - local t_280_ = _3fopts - if (nil ~= t_280_) then - t_280_ = (t_280_)["macro?"] - else + local _275_0 = _3fopts + if (nil ~= _275_0) then + _275_0 = _275_0["macro?"] end - macro_3f = t_280_ + macro_3f = _275_0 end - assert_compile(not name:find("&"), "invalid character: &") - assert_compile(not name:find("^%."), "invalid character: .") + assert_compile(not name:find("&"), "invalid character: &", symbol) + assert_compile(not name:find("^%."), "invalid character: .", symbol) assert_compile(not (scope.specials[name] or (not macro_3f and scope.macros[name])), ("local %s was overshadowed by a special form or macro"):format(name), ast) return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol) end @@ -2616,7 +2576,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct check_binding_valid(symbol, scope, ast) local name = tostring(symbol) assert_compile(not utils["multi-sym?"](name), ("unexpected multi symbol " .. name), ast) - do end (scope.symmeta)[name] = meta + scope.symmeta[name] = meta return local_mangling(name, scope, ast, _3ftemp_manglings) end local function hashfn_arg_name(name, multi_sym_parts, scope) @@ -2627,11 +2587,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif multi_sym_parts then if (multi_sym_parts and (multi_sym_parts[1] == "$")) then multi_sym_parts[1] = "$1" - else end return table.concat(multi_sym_parts, ".") - else - return nil end end local function symbol_to_expression(symbol, scope, _3freference_3f) @@ -2644,14 +2601,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local local_3f = scope.manglings[parts[1]] if (local_3f and scope.symmeta[parts[1]]) then scope.symmeta[parts[1]]["used"] = true - else end - assert_compile(not scope.macros[parts[1]], "tried to reference a macro at runtime", symbol) - assert_compile((not scope.specials[parts[1]] or ("require" == parts[1])), "tried to reference a special form at runtime", symbol) - assert_compile((not _3freference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown identifier in strict mode: " .. tostring(parts[1])), symbol) + assert_compile(not scope.macros[parts[1]], "tried to reference a macro without calling it", symbol) + assert_compile((not scope.specials[parts[1]] or ("require" == parts[1])), "tried to reference a special form without calling it", symbol) + assert_compile((not _3freference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown identifier: " .. tostring(parts[1])), symbol) if (allowed_globals and not local_3f and scope.parent) then scope.parent.refedglobals[parts[1]] = true - else end return utils.expr(combine_parts(parts, scope), etype) end @@ -2690,10 +2645,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local source = utils["ast-source"](subchunk.ast) if (file == source.filename) then last_line0 = math.max(last_line0, (source.line or 0)) - else end last_line0 = flatten(subchunk, out, last_line0, file) - else end end end @@ -2704,32 +2657,31 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for i = 1, last do if (out[i] == nil) then out[i] = "" - else end end return table.concat(out, "\n") end local function flatten_chunk(file_sourcemap, chunk, tab, depth) if chunk.leaf then - local _let_292_ = utils["ast-source"](chunk.ast) - local filename = _let_292_["filename"] - local line = _let_292_["line"] + local _287_ = utils["ast-source"](chunk.ast) + local filename = _287_["filename"] + local line = _287_["line"] table.insert(file_sourcemap, {filename, line}) return chunk.leaf else - local tab0 + local tab0 = nil do - local _293_ = tab - if (_293_ == true) then + local _288_0 = tab + if (_288_0 == true) then tab0 = " " - elseif (_293_ == false) then + elseif (_288_0 == false) then tab0 = "" - elseif (_293_ == tab) then + elseif (_288_0 == tab) then tab0 = tab - elseif (_293_ == nil) then + elseif (_288_0 == nil) then tab0 = "" else - tab0 = nil + tab0 = nil end end local function parter(c) @@ -2740,8 +2692,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else return sub end - else - return nil end end return table.concat(utils.map(chunk, parter), "\n") @@ -2774,24 +2724,21 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function make_metadata() - local function _301_(self, tgt, key) + local function _296_(self, tgt, key) if self[tgt] then return self[tgt][key] - else - return nil end end - local function _303_(self, tgt, key, value) + local function _298_(self, tgt, key, value) self[tgt] = (self[tgt] or {}) - do end (self[tgt])[key] = value + self[tgt][key] = value return tgt end - local function _304_(self, tgt, ...) + local function _299_(self, tgt, ...) local kv_len = select("#", ...) local kvs = {...} if ((kv_len % 2) ~= 0) then error("metadata:setall() expected even number of k/v pairs") - else end self[tgt] = (self[tgt] or {}) for i = 1, kv_len, 2 do @@ -2799,7 +2746,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return tgt end - return setmetatable({}, {__index = {get = _301_, set = _303_, setall = _304_}, __mode = "k"}) + return setmetatable({}, {__index = {get = _296_, set = _298_, setall = _299_}, __mode = "k"}) end local function exprs1(exprs) return table.concat(utils.map(exprs, tostring), ", ") @@ -2812,14 +2759,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) elseif (se.type == "statement") then local code = tostring(se) - local disambiguated + local disambiguated = nil if (code:byte() == 40) then disambiguated = ("do end " .. code) else disambiguated = code end emit(chunk, disambiguated, ast) - else end end return nil @@ -2839,47 +2785,42 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct exprs[i] = utils.expr("nil", "literal") end end - else end - else end if opts.tail then emit(parent, string.format("return %s", exprs1(exprs)), ast) - else end if opts.target then local result = exprs1(exprs) - local function _312_() + local function _307_() if (result == "") then return "nil" else return result end end - emit(parent, string.format("%s = %s", opts.target, _312_()), ast) - else + emit(parent, string.format("%s = %s", opts.target, _307_()), ast) end if (opts.tail or opts.target) then return {returned = true} else - local _314_ = exprs - _314_["returned"] = true - return _314_ + exprs["returned"] = true + return exprs end end local function find_macro(ast, scope) - local macro_2a + local macro_2a = nil do - local _316_ = utils["sym?"](ast[1]) - if (_316_ ~= nil) then - local _317_ = tostring(_316_) - if (_317_ ~= nil) then - macro_2a = scope.macros[_317_] + local _310_0 = utils["sym?"](ast[1]) + if (_310_0 ~= nil) then + local _311_0 = tostring(_310_0) + if (_311_0 ~= nil) then + macro_2a = scope.macros[_311_0] else - macro_2a = _317_ + macro_2a = _311_0 end else - macro_2a = _316_ + macro_2a = _310_0 end end local multi_sym_parts = utils["multi-sym?"](ast[1]) @@ -2891,50 +2832,37 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return macro_2a end end - local function propagate_trace_info(_321_, _index, node) - local _arg_322_ = _321_ - local filename = _arg_322_["filename"] - local line = _arg_322_["line"] - local bytestart = _arg_322_["bytestart"] - local byteend = _arg_322_["byteend"] + local function propagate_trace_info(_315_0, _index, node) + local _316_ = _315_0 + local byteend = _316_["byteend"] + local bytestart = _316_["bytestart"] + local filename = _316_["filename"] + local line = _316_["line"] do local src = utils["ast-source"](node) if (("table" == type(node)) and (filename ~= src.filename)) then src.filename, src.line, src["from-macro?"] = filename, line, true src.bytestart, src.byteend = bytestart, byteend - else end end return ("table" == type(node)) end - local function max_n(t) - local n = 0 - for k in pairs(t) do - if ("number" == type(k)) then - n = math.max(k, n) - else - end - end - return n - end local function quote_literal_nils(index, node, parent) if (parent and utils["list?"](parent)) then - for i = 1, max_n(parent) do - local _325_ = parent[i] - if (_325_ == nil) then + for i = 1, utils.maxn(parent) do + local _318_0 = parent[i] + if (_318_0 == nil) then parent[i] = utils.sym("nil") - else end end - else end return index, node, parent end local function comp(f, g) - local function _328_(...) + local function _321_(...) return f(g(...)) end - return _328_ + return _321_ end local function built_in_3f(m) local found_3f = false @@ -2945,41 +2873,36 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return found_3f end local function macroexpand_2a(ast, scope, _3fonce) - local _329_ + local _322_0 = nil if utils["list?"](ast) then - _329_ = find_macro(ast, scope) + _322_0 = find_macro(ast, scope) else - _329_ = nil + _322_0 = nil end - if (_329_ == false) then + if (_322_0 == false) then return ast - elseif (nil ~= _329_) then - local macro_2a = _329_ + elseif (nil ~= _322_0) then + local macro_2a = _322_0 local old_scope = scopes.macro - local _ + local _ = nil scopes.macro = scope _ = nil local ok, transformed = nil, nil - local function _331_() + local function _324_() return macro_2a(unpack(ast, 2)) end - local function _332_() + local function _325_() if built_in_3f(macro_2a) then return tostring else return debug.traceback end end - ok, transformed = xpcall(_331_, _332_()) - local _334_ - do - local _333_ = ast - local function _335_(...) - return propagate_trace_info(_333_, ...) - end - _334_ = _335_ + ok, transformed = xpcall(_324_, _325_()) + local function _326_(...) + return propagate_trace_info(ast, ...) end - utils["walk-tree"](transformed, comp(_334_, quote_literal_nils)) + utils["walk-tree"](transformed, comp(_326_, quote_literal_nils)) scopes.macro = old_scope assert_compile(ok, transformed, ast) if (_3fonce or not transformed) then @@ -2987,22 +2910,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else return macroexpand_2a(transformed, scope) end - elseif true then - local _ = _329_ - return ast else - return nil + local _ = _322_0 + return ast end end local function compile_special(ast, scope, parent, opts, special) local exprs = (special(ast, scope, parent, opts) or utils.expr("nil", "literal")) - local exprs0 + local exprs0 = nil if ("table" ~= type(exprs)) then exprs0 = utils.expr(exprs, "expression") else exprs0 = exprs end - local exprs2 + local exprs2 = nil if utils["expr?"](exprs0) then exprs2 = {exprs0} else @@ -3018,17 +2939,17 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function compile_function_call(ast, scope, parent, opts, compile1, len) local fargs = {} - local fcallee = (compile1(ast[1], scope, parent, {nval = 1}))[1] + local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1] assert_compile((utils["sym?"](ast[1]) or utils["list?"](ast[1]) or ("string" == type(ast[1]))), ("cannot call literal value " .. tostring(ast[1])), ast) for i = 2, len do - local subexprs - local _341_ + local subexprs = nil + local _332_ if (i ~= len) then - _341_ = 1 + _332_ = 1 else - _341_ = nil + _332_ = nil end - subexprs = compile1(ast[i], scope, parent, {nval = _341_}) + subexprs = compile1(ast[i], scope, parent, {nval = _332_}) table.insert(fargs, subexprs[1]) if (i == len) then for j = 2, #subexprs do @@ -3038,7 +2959,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct keep_side_effects(subexprs, parent, 2, ast[i]) end end - local pat + local pat = nil if ("string" == type(ast[1])) then pat = "(%s)(%s)" else @@ -3066,19 +2987,19 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function compile_varg(ast, scope, parent, opts) - local _346_ + local _337_ if scope.hashfn then - _346_ = "use $... in hashfn" + _337_ = "use $... in hashfn" else - _346_ = "unexpected vararg" + _337_ = "unexpected vararg" end - assert_compile(scope.vararg, _346_, ast) + assert_compile(scope.vararg, _337_, ast) return handle_compile_opts({utils.expr("...", "varg")}, parent, opts, ast) end local function compile_sym(ast, scope, parent, opts) local multi_sym_parts = utils["multi-sym?"](ast) assert_compile(not (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]), "multisym method calls may only be in call position", ast) - local e + local e = nil if (ast[1] == "nil") then e = utils.expr("nil", "literal") else @@ -3087,71 +3008,73 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return handle_compile_opts({e}, parent, opts, ast) end local function serialize_number(n) - local _349_ = string.gsub(tostring(n), ",", ".") - return _349_ + local _340_0 = string.gsub(tostring(n), ",", ".") + return _340_0 end local function compile_scalar(ast, _scope, parent, opts) - local serialize + local serialize = nil do - local _350_ = type(ast) - if (_350_ == "nil") then + local _341_0 = type(ast) + if (_341_0 == "nil") then serialize = tostring - elseif (_350_ == "boolean") then + elseif (_341_0 == "boolean") then serialize = tostring - elseif (_350_ == "string") then + elseif (_341_0 == "string") then serialize = serialize_string - elseif (_350_ == "number") then + elseif (_341_0 == "number") then serialize = serialize_number else - serialize = nil + serialize = nil end end return handle_compile_opts({utils.expr(serialize(ast), "literal")}, parent, opts) end local function compile_table(ast, scope, parent, opts, compile1) - local buffer = {} - local function write_other_values(k) - if ((type(k) ~= "number") or (math.floor(k) ~= k) or (k < 1) or (#ast < k)) then - if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then - return {k, k} - else - local _let_352_ = compile1(k, scope, parent, {nval = 1}) - local compiled = _let_352_[1] - local kstr = ("[" .. tostring(compiled) .. "]") - return {kstr, k} - end + local function escape_key(k) + if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then + return k else - return nil + local _343_ = compile1(k, scope, parent, {nval = 1}) + local compiled = _343_[1] + return ("[" .. tostring(compiled) .. "]") end end + local keys = {} + local buffer = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i, elem in ipairs(ast) do + local val_19_ = nil + do + local nval = ((nil ~= ast[(i + 1)]) and 1) + keys[i] = true + val_19_ = exprs1(compile1(elem, scope, parent, {nval = nval})) + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + buffer = tbl_17_ + end do - local keys - do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for k, v in utils.stablepairs(ast) do - local val_16_auto = write_other_values(k, v) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else - end + local tbl_17_ = buffer + local i_18_ = #tbl_17_ + for k, v in utils.stablepairs(ast) do + local val_19_ = nil + if not keys[k] then + local _346_ = compile1(ast[k], scope, parent, {nval = 1}) + local v0 = _346_[1] + val_19_ = string.format("%s = %s", escape_key(k), tostring(v0)) + else + val_19_ = nil + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end - keys = tbl_14_auto end - local function _358_(_356_) - local _arg_357_ = _356_ - local k1 = _arg_357_[1] - local k2 = _arg_357_[2] - local _let_359_ = compile1(ast[k2], scope, parent, {nval = 1}) - local v = _let_359_[1] - return string.format("%s = %s", k1, tostring(v)) - end - utils.map(keys, _358_, buffer) - end - for i = 1, #ast do - local nval = ((i ~= #ast) and 1) - table.insert(buffer, exprs1(compile1(ast[i], scope, parent, {nval = nval}))) end return handle_compile_opts({utils.expr(("{" .. table.concat(buffer, ", ") .. "}"), "expression")}, parent, opts, ast) end @@ -3174,14 +3097,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function destructure(to, from, ast, scope, parent, opts) local opts0 = (opts or {}) - local _let_361_ = opts0 - local isvar = _let_361_["isvar"] - local declaration = _let_361_["declaration"] - local forceglobal = _let_361_["forceglobal"] - local forceset = _let_361_["forceset"] - local symtype = _let_361_["symtype"] + local _350_ = opts0 + local declaration = _350_["declaration"] + local forceglobal = _350_["forceglobal"] + local forceset = _350_["forceset"] + local isvar = _350_["isvar"] + local symtype = _350_["symtype"] local symtype0 = ("_" .. (symtype or "dst")) - local setter + local setter = nil if declaration then setter = "local %s = %s" else @@ -3200,32 +3123,29 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if ((#parts == 1) and not forceset) then assert_compile(not (forceglobal and meta), string.format("global %s conflicts with local", tostring(symbol)), symbol) assert_compile(not (meta and not meta.var), ("expected var " .. raw), symbol) - assert_compile((meta or not opts0.noundef), ("expected local " .. parts[1]), symbol) - else end + assert_compile((meta or not opts0.noundef or global_allowed_3f(parts[1])), ("expected local " .. parts[1]), symbol) if forceglobal then assert_compile(not scope.symmeta[scope.unmanglings[raw]], ("global " .. raw .. " conflicts with local"), symbol) - do end (scope.manglings)[raw] = global_mangling(raw) - do end (scope.unmanglings)[global_mangling(raw)] = raw + scope.manglings[raw] = global_mangling(raw) + scope.unmanglings[global_mangling(raw)] = raw if allowed_globals then table.insert(allowed_globals, raw) - else end - else end return symbol_to_expression(symbol, scope)[1] end end local function compile_top_target(lvalues) - local inits - local function _367_(_241) + local inits = nil + local function _356_(_241) if scope.manglings[_241] then return _241 else return "nil" end end - inits = utils.map(lvalues, _367_) + inits = utils.map(lvalues, _356_) local init = table.concat(inits, ", ") local lvalue = table.concat(lvalues, ", ") local plast = parent[#parent] @@ -3235,7 +3155,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for pi = plen, #parent do if (parent[pi] == plast) then plen = pi - else end end if ((#parent == (plen + 1)) and parent[#parent].leaf) then @@ -3245,7 +3164,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue .. " = " .. init)}) end - else end return ret end @@ -3260,28 +3178,25 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if declaration then scope.symmeta[tostring(left)] = {var = isvar} return nil - else - return nil end end local unpack_fn = "function (t, k, e)\n local mt = getmetatable(t)\n if 'table' == type(mt) and mt.__fennelrest then\n return mt.__fennelrest(t, k)\n elseif e then\n local rest = {}\n for k, v in pairs(t) do\n if not e[k] then rest[k] = v end\n end\n return rest\n else\n return {(table.unpack or unpack)(t, k)}\n end\n end" local function destructure_kv_rest(s, v, left, excluded_keys, destructure1) - local exclude_str - local _374_ + local exclude_str = nil + local _363_ do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, k in ipairs(excluded_keys) do - local val_16_auto = string.format("[%s] = true", serialize_string(k)) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = string.format("[%s] = true", serialize_string(k)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _374_ = tbl_14_auto + _363_ = tbl_17_ end - exclude_str = table.concat(_374_, ", ") + exclude_str = table.concat(_363_, ", ") local subexpr = utils.expr(string.format(string.gsub(("(" .. unpack_fn .. ")(%s, %s, {%s})"), "\n%s*", " "), s, tostring(v), exclude_str), "expression") return destructure1(v, {subexpr}, left) end @@ -3294,21 +3209,21 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function destructure_table(left, rightexprs, top_3f, destructure1) local s = gensym(scope, symtype0) - local right + local right = nil do - local _376_ + local _365_0 = nil if top_3f then - _376_ = exprs1(compile1(from, scope, parent)) + _365_0 = exprs1(compile1(from, scope, parent)) else - _376_ = exprs1(rightexprs) + _365_0 = exprs1(rightexprs) end - if (_376_ == "") then + if (_365_0 == "") then right = "nil" - elseif (nil ~= _376_) then - local right0 = _376_ + elseif (nil ~= _365_0) then + local right0 = _365_0 right = right0 else - right = nil + right = nil end end local excluded_keys = {} @@ -3326,7 +3241,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct assert_compile((nil == trailing), "expected &as argument before last parameter", left) destructure_sym(next_sym, {utils.expr(tostring(s))}, left) else - local key + local key = nil if (type(k) == "string") then key = serialize_string(k) else @@ -3335,11 +3250,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression") if (type(k) == "string") then table.insert(excluded_keys, k) - else end destructure1(v, {subexpr}, left) end - else end end return nil @@ -3352,7 +3265,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else local symname = gensym(scope, symtype0) table.insert(left_names, symname) - do end (tables)[i] = {name, utils.expr(symname, "sym")} + tables[i] = {name, utils.expr(symname, "sym")} end end assert_compile(left[1], "must provide at least one value", left) @@ -3362,10 +3275,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for _, sym in ipairs(left) do if utils["sym?"](sym) then scope.symmeta[tostring(sym)] = {var = isvar} - else end end - else end for _, pair in utils.stablepairs(tables) do destructure1(pair[1], {pair[2]}, left) @@ -3380,12 +3291,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif utils["list?"](left) then destructure_values(left, up1, top_3f, destructure1) else - assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type((up1)[2]) == "table") and (up1)[2]) or up1)) + assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1)) end if top_3f then return {returned = true} - else - return nil end end local ret = destructure1(to, nil, ast, true) @@ -3397,7 +3306,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct opts.fallback = function(e, no_warn) if (not no_warn and ("literal" == e.type)) then utils.warn(("include module not found, falling back to require: %s"):format(tostring(e))) - else end return utils.expr(string.format("require(%s)", tostring(e)), "statement") end @@ -3409,15 +3317,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local scope = (opts.scope or make_scope(scopes.global)) local vals = {} local chunk = {} - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") + local _378_ = utils.root + _378_["set-reset"](_378_) allowed_globals = opts.allowedGlobals if (opts.indent == nil) then opts.indent = " " - else end if opts.requireAsInclude then scope.specials.require = require_include - else end utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts for _, val in parser.parser(strm, opts.filename, opts) do @@ -3428,30 +3335,29 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct keep_side_effects(exprs, chunk, nil, vals[i]) if (i == #vals) then utils.hook("chunk", vals[i], scope) - else end end allowed_globals = old_globals utils.root.reset() return flatten(chunk, opts) end - local function compile_string(str, opts) - return compile_stream(parser["string-stream"](str), (opts or {})) + local function compile_string(str, _3fopts) + local opts = (_3fopts or {}) + return compile_stream(parser["string-stream"](str, opts), opts) end local function compile(ast, opts) local opts0 = utils.copy(opts) local old_globals = allowed_globals local chunk = {} local scope = (opts0.scope or make_scope(scopes.global)) - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") + local _382_ = utils.root + _382_["set-reset"](_382_) allowed_globals = opts0.allowedGlobals if (opts0.indent == nil) then opts0.indent = " " - else end if opts0.requireAsInclude then scope.specials.require = require_include - else end utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts0 local exprs = compile1(ast, scope, chunk, {tail = true}) @@ -3475,17 +3381,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct info.short_src = remap.short_src end info.currentline = (remap[info.currentline][2] or -1) - else end if (info.what == "Lua") then - local function _396_() + local function _387_() if info.name then return ("'" .. info.name .. "'") else return "?" end end - return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _396_()) + return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _387_()) elseif (info.short_src == "(tail call)") then return " (tail call)" else @@ -3495,11 +3400,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function traceback(_3fmsg, _3fstart) local msg = tostring((_3fmsg or "")) - if ((msg:find("^Compile error") or msg:find("^Parse error")) and not utils["debug-on?"]("trace")) then + if ((msg:find("^%g+:%d+:%d+ Compile error:.*") or msg:find("^%g+:%d+:%d+ Parse error:.*")) and not utils["debug-on?"]("trace")) then return msg else local lines = {} - if (msg:find(":%d+: Compile error") or msg:find(":%d+: Parse error")) then + if (msg:find("^%g+:%d+:%d+ Compile error:") or msg:find("^%g+:%d+:%d+ Parse error:")) then table.insert(lines, msg) else local newmsg = msg:gsub("^[^:]*:%d+:%s+", "runtime error: ") @@ -3509,13 +3414,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local done_3f, level = false, (_3fstart or 2) while not done_3f do do - local _400_ = debug.getinfo(level, "Sln") - if (_400_ == nil) then + local _391_0 = debug.getinfo(level, "Sln") + if (_391_0 == nil) then done_3f = true - elseif (nil ~= _400_) then - local info = _400_ + elseif (nil ~= _391_0) then + local info = _391_0 table.insert(lines, traceback_frame(info)) - else end end level = (level + 1) @@ -3524,14 +3428,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function entry_transform(fk, fv) - local function _403_(k, v) + local function _394_(k, v) if (type(k) == "number") then return k, fv(v) else return fk(k), fv(v) end end - return _403_ + return _394_ end local function mixed_concat(t, joiner) local seen = {} @@ -3545,7 +3449,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if not seen[k] then ret = (ret .. s .. "[" .. k .. "]" .. "=" .. v) s = joiner - else end end return ret @@ -3558,7 +3461,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct assert_compile(not runtime_3f, "quoted ... may only be used at compile time", form) return "_VARARG" elseif utils["sym?"](form) then - local filename + local filename = nil if form.filename then filename = string.format("%q", form.filename) else @@ -3576,12 +3479,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local res = unpack(compile1(payload, scope, parent)) return res[1] elseif utils["list?"](form) then - local mapped - local function _408_() + local mapped = nil + local function _399_() return nil end - mapped = utils.kvmap(form, entry_transform(_408_, q)) - local filename + mapped = utils.kvmap(form, entry_transform(_399_, q)) + local filename = nil if form.filename then filename = string.format("%q", form.filename) else @@ -3592,67 +3495,70 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif utils["sequence?"](form) then local mapped = utils.kvmap(form, entry_transform(q, q)) local source = getmetatable(form) - local filename + local filename = nil if source.filename then filename = string.format("%q", source.filename) else filename = "nil" end - local _411_ + local _402_ if source then - _411_ = source.line + _402_ = source.line else - _411_ = "nil" + _402_ = "nil" end - return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _411_, "(getmetatable(sequence()))['sequence']") + return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _402_, "(getmetatable(sequence()))['sequence']") elseif (type(form) == "table") then local mapped = utils.kvmap(form, entry_transform(q, q)) local source = getmetatable(form) - local filename + local filename = nil if source.filename then filename = string.format("%q", source.filename) else filename = "nil" end - local function _414_() + local function _405_() if source then return source.line else return "nil" end end - return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _414_()) + return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _405_()) elseif (type(form) == "string") then return serialize_string(form) else return tostring(form) end end - return {compile = compile, compile1 = compile1, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["check-binding-valid"] = check_binding_valid, emit = emit, destructure = destructure, ["require-include"] = require_include, autogensym = autogensym, gensym = gensym, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["apply-manglings"] = apply_manglings, macroexpand = macroexpand_2a, ["declare-local"] = declare_local, ["make-scope"] = make_scope, ["keep-side-effects"] = keep_side_effects, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, scopes = scopes, traceback = traceback, metadata = make_metadata(), sourcemap = sourcemap} + return {["apply-manglings"] = apply_manglings, ["check-binding-valid"] = check_binding_valid, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["declare-local"] = declare_local, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["keep-side-effects"] = keep_side_effects, ["make-scope"] = make_scope, ["require-include"] = require_include, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, autogensym = autogensym, compile = compile, compile1 = compile1, destructure = destructure, emit = emit, gensym = gensym, macroexpand = macroexpand_2a, metadata = make_metadata(), scopes = scopes, sourcemap = sourcemap, traceback = traceback} end package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...) local utils = require("fennel.utils") local utf8_ok_3f, utf8 = pcall(require, "utf8") - local suggestions = {["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["unknown identifier in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["tried to reference a macro at runtime"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form at runtime"] = {"wrapping the special in a function if you need it to be first class"}, ["missing subject"] = {"adding an item to operate on"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}} + local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name", "making sure to use prefix operators, not infix"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["missing subject"] = {"adding an item to operate on"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["tried to reference a macro without calling it"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form without calling it"] = {"making sure to use prefix operators, not infix", "wrapping the special in a function if you need it to be first class"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown identifier: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} local unpack = (table.unpack or _G.unpack) local function suggest(msg) - local suggestion = nil + local s = nil for pat, sug in pairs(suggestions) do + if s then break end local matches = {msg:match(pat)} if (0 < #matches) then - if ("table" == type(sug)) then - local out = {} - for _, s in ipairs(sug) do - table.insert(out, s:format(unpack(matches))) + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, s0 in ipairs(sug) do + local val_19_ = s0:format(unpack(matches)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end - suggestion = out - else - suggestion = sug(matches) end + s = tbl_17_ else + s = nil end end - return suggestion + return s end local function read_line(filename, line, _3fsource) if _3fsource then @@ -3663,9 +3569,9 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( return matcher() else local f = assert(io.open(filename)) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) @@ -3677,11 +3583,11 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( end return f:read() end - return close_handlers_8_auto(_G.xpcall(_178_, (package.loaded.fennel or debug).traceback)) + return close_handlers_10_(_G.xpcall(_178_, (package.loaded.fennel or debug).traceback)) end end local function sub(str, start, _end) - if (_end < start) then + if ((_end < start) or (#str < start) or (#str < _end)) then return "" elseif utf8_ok_3f then return string.sub(str, utf8.offset(str, start), ((utf8.offset(str, (_end + 1)) or (utf8.len(str) + 1)) - 1)) @@ -3689,50 +3595,57 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( return string.sub(str, start, math.min(_end, str:len())) end end - local function highlight_line(codeline, col, _3fendcol) - local endcol = (_3fendcol or col) - local eol - if utf8_ok_3f then - eol = utf8.len(codeline) + local function highlight_line(codeline, col, _3fendcol, opts) + if ((opts and (false == opts["error-pinpoint"])) or (os and os.getenv and os.getenv("NO_COLOR"))) then + return codeline else - eol = string.len(codeline) + local _181_ = (opts or {}) + local error_pinpoint = _181_["error-pinpoint"] + local endcol = (_3fendcol or col) + local eol = nil + if utf8_ok_3f then + eol = utf8.len(codeline) + else + eol = string.len(codeline) + end + local _183_ = (error_pinpoint or {"\27[7m", "\27[0m"}) + local open = _183_[1] + local close = _183_[2] + return (sub(codeline, 1, col) .. open .. sub(codeline, (col + 1), (endcol + 1)) .. close .. sub(codeline, (endcol + 2), eol)) end - return (sub(codeline, 1, col) .. "\27[7m" .. sub(codeline, (col + 1), (endcol + 1)) .. "\27[0m" .. sub(codeline, (endcol + 2), eol)) end - local function friendly_msg(msg, _182_, source) - local _arg_183_ = _182_ - local filename = _arg_183_["filename"] - local line = _arg_183_["line"] - local col = _arg_183_["col"] - local endcol = _arg_183_["endcol"] + local function friendly_msg(msg, _185_0, source, opts) + local _186_ = _185_0 + local col = _186_["col"] + local endcol = _186_["endcol"] + local filename = _186_["filename"] + local line = _186_["line"] local ok, codeline = pcall(read_line, filename, line, source) local out = {msg, ""} if (ok and codeline) then if col then - table.insert(out, highlight_line(codeline, col, endcol)) + table.insert(out, highlight_line(codeline, col, endcol, opts)) else table.insert(out, codeline) end - else end for _, suggestion in ipairs((suggest(msg) or {})) do table.insert(out, ("* Try %s."):format(suggestion)) end return table.concat(out, "\n") end - local function assert_compile(condition, msg, ast, source) + local function assert_compile(condition, msg, ast, source, opts) if not condition then - local _let_186_ = utils["ast-source"](ast) - local filename = _let_186_["filename"] - local line = _let_186_["line"] - local col = _let_186_["col"] - error(friendly_msg(("Compile error in %s:%s:%s\n %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source), 0) - else + local _189_ = utils["ast-source"](ast) + local col = _189_["col"] + local filename = _189_["filename"] + local line = _189_["line"] + error(friendly_msg(("%s:%s:%s Compile error: %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source, opts), 0) end return condition end - local function parse_error(msg, filename, line, col, source) - return error(friendly_msg(("Parse error in %s:%s:%s\n %s"):format(filename, line, col, msg), {filename = filename, line = line, col = col}, source), 0) + local function parse_error(msg, filename, line, col, source, opts) + return error(friendly_msg(("%s:%s:%s Parse error: %s"):format(filename, line, col, msg), {col = col, filename = filename, line = line}, source, opts), 0) end return {["assert-compile"] = assert_compile, ["parse-error"] = parse_error} end @@ -3742,54 +3655,53 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( local unpack = (table.unpack or _G.unpack) local function granulate(getchunk) local c, index, done_3f = "", 1, false - local function _188_(parser_state) + local function _191_(parser_state) if not done_3f then if (index <= #c) then local b = c:byte(index) index = (index + 1) return b else - local _189_ = getchunk(parser_state) - local function _190_() - local char = _189_ + local _192_0 = getchunk(parser_state) + local function _193_() + local char = _192_0 return (char ~= "") end - if ((nil ~= _189_) and _190_()) then - local char = _189_ + if ((nil ~= _192_0) and _193_()) then + local char = _192_0 c = char index = 2 return c:byte() - elseif true then - local _ = _189_ - done_3f = true - return nil else + local _ = _192_0 + done_3f = true return nil end end - else - return nil end end - local function _194_() + local function _197_() c = "" return nil end - return _188_, _194_ + return _191_, _197_ end - local function string_stream(str) + local function string_stream(str, _3foptions) local str0 = str:gsub("^#!", ";;") + if _3foptions then + _3foptions.source = str0 + end local index = 1 - local function _195_() + local function _199_() local r = str0:byte(index) index = (index + 1) return r end - return _195_ + return _199_ end - local delims = {[40] = 41, [41] = true, [91] = 93, [93] = true, [123] = 125, [125] = true} + local delims = {[123] = 125, [125] = true, [40] = 41, [41] = true, [91] = 93, [93] = true} local function sym_char_3f(b) - local b0 + local b0 = nil if ("number" == type(b)) then b0 = b else @@ -3799,24 +3711,22 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"} local function char_starter_3f(b) - return ((function(_197_,_198_,_199_) return (_197_ < _198_) and (_198_ < _199_) end)(1,b,127) or (function(_200_,_201_,_202_) return (_200_ < _201_) and (_201_ < _202_) end)(192,b,247)) + return (((1 < b) and (b < 127)) or ((192 < b) and (b < 247))) end - local function parser_fn(getbyte, filename, _203_) - local _arg_204_ = _203_ - local source = _arg_204_["source"] - local unfriendly = _arg_204_["unfriendly"] - local comments = _arg_204_["comments"] - local options = _arg_204_ + local function parser_fn(getbyte, filename, _201_0) + local _202_ = _201_0 + local options = _202_ + local comments = _202_["comments"] + local source = _202_["source"] + local unfriendly = _202_["unfriendly"] local stack = {} local line, byteindex, col, prev_col, lastb = 1, 0, 0, 0, nil local function ungetb(ub) if char_starter_3f(ub) then col = (col - 1) - else end if (ub == 10) then line, col = (line - 1), prev_col - else end byteindex = (byteindex - 1) lastb = ub @@ -3832,24 +3742,21 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( byteindex = (byteindex + 1) if (r and char_starter_3f(r)) then col = (col + 1) - else end if (r == 10) then line, col, prev_col = (line + 1), 0, col - else end return r end local function whitespace_3f(b) - local function _214_() - local t_213_ = options.whitespace - if (nil ~= t_213_) then - t_213_ = (t_213_)[b] - else + local function _209_() + local _208_0 = options.whitespace + if (nil ~= _208_0) then + _208_0 = _208_0[b] end - return t_213_ + return _208_0 end - return ((b == 32) or (function(_210_,_211_,_212_) return (_210_ <= _211_) and (_211_ <= _212_) end)(9,b,13) or _214_()) + return ((b == 32) or ((9 <= b) and (b <= 13)) or _209_()) end local function parse_error(msg, _3fcol_adjust) local col0 = (col + (_3fcol_adjust or -1)) @@ -3858,10 +3765,8 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if (unfriendly or not _G.io or not _G.io.read) then return error(string.format("%s:%s:%s Parse error: %s", filename, (line or "?"), col0, msg), 0) else - return friend["parse-error"](msg, filename, (line or "?"), col0, source) + return friend["parse-error"](msg, filename, (line or "?"), col0, source, options) end - else - return nil end end local function parse_stream() @@ -3871,29 +3776,27 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return nil end local function dispatch(v) - local _218_ = stack[#stack] - if (_218_ == nil) then + local _213_0 = stack[#stack] + if (_213_0 == nil) then retval, done_3f, whitespace_since_dispatch = v, true, false return nil - elseif ((_G.type(_218_) == "table") and (nil ~= (_218_).prefix)) then - local prefix = (_218_).prefix - local source0 + elseif ((_G.type(_213_0) == "table") and (nil ~= _213_0.prefix)) then + local prefix = _213_0.prefix + local source0 = nil do - local _219_ = table.remove(stack) - set_source_fields(_219_) - source0 = _219_ + local _214_0 = table.remove(stack) + set_source_fields(_214_0) + source0 = _214_0 end local list = utils.list(utils.sym(prefix, source0), v) for k, v0 in pairs(source0) do list[k] = v0 end return dispatch(list) - elseif (nil ~= _218_) then - local top = _218_ + elseif (nil ~= _213_0) then + local top = _213_0 whitespace_since_dispatch = false return table.insert(top, v) - else - return nil end end local function close_list(list) @@ -3907,27 +3810,27 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return dispatch(val) end local function add_comment_at(comments0, index, node) - local _221_ = (comments0)[index] - if (nil ~= _221_) then - local existing = _221_ + local _216_0 = comments0[index] + if (nil ~= _216_0) then + local existing = _216_0 return table.insert(existing, node) - elseif true then - local _ = _221_ - comments0[index] = {node} - return nil else + local _ = _216_0 + comments0[index] = {node} return nil end end local function next_noncomment(tbl, i) if utils["comment?"](tbl[i]) then return next_noncomment(tbl, (i + 1)) + elseif (utils.sym(":") == tbl[i]) then + return tostring(tbl[(i + 1)]) else return tbl[i] end end local function extract_comments(tbl) - local comments0 = {keys = {}, values = {}, last = {}} + local comments0 = {keys = {}, last = {}, values = {}} while utils["comment?"](tbl[#tbl]) do table.insert(comments0.last, 1, table.remove(tbl)) end @@ -3944,7 +3847,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( for i = #tbl, 1, -1 do if utils["comment?"](tbl[i]) then table.remove(tbl, i) - else end end return comments0 @@ -3956,13 +3858,11 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if ((#tbl % 2) ~= 0) then byteindex = (byteindex - 1) parse_error("expected even number of values in table literal") - else end setmetatable(val, tbl) for i = 1, #tbl, 2 do if ((tostring(tbl[i]) == ":") and utils["sym?"](tbl[(i + 1)]) and utils["sym?"](tbl[i])) then tbl[i] = tostring(tbl[(i + 1)]) - else end val[tbl[i]] = tbl[(i + 1)] table.insert(keys, tbl[i]) @@ -3975,11 +3875,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( local top = table.remove(stack) if (top == nil) then parse_error(("unexpected closing delimiter " .. string.char(b))) - else end if (top.closer and (top.closer ~= b)) then parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) - else end set_source_fields(top) if (b == 41) then @@ -3992,20 +3890,18 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end local function badend(cause) local accum = utils.map(stack, "closer") - local _231_ + local _226_ if (#stack == 1) then - _231_ = "" + _226_ = "" else - _231_ = "s" + _226_ = "s" end - parse_error(string.format("expected closing delimiter%s %s", _231_, string.char(unpack(accum)))) + parse_error(string.format("expected closing delimiter%s %s", _226_, string.char(unpack(accum)))) if (cause == "eof") then for i = #accum, 2, -1 do close_table(accum[i]) end return accum[1] - else - return nil end end local function skip_whitespace(b) @@ -4020,43 +3916,37 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end local function parse_comment(b, contents) if (b and (10 ~= b)) then - local function _236_() - local _235_ = contents - table.insert(_235_, string.char(b)) - return _235_ + local function _230_() + table.insert(contents, string.char(b)) + return contents end - return parse_comment(getb(), _236_()) + return parse_comment(getb(), _230_()) elseif comments then ungetb(10) - return dispatch(utils.comment(table.concat(contents), {line = (line - 1), filename = filename})) - else - return nil + return dispatch(utils.comment(table.concat(contents), {filename = filename, line = line})) end end local function open_table(b) if not whitespace_since_dispatch then parse_error(("expected whitespace before opening delimiter " .. string.char(b))) - else end - return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line, col = (col - 1)}) + return table.insert(stack, {bytestart = byteindex, closer = delims[b], col = (col - 1), filename = filename, line = line}) end local function parse_string_loop(chars, b, state) table.insert(chars, b) - local state0 + local state0 = nil do - local _239_ = {state, b} - if ((_G.type(_239_) == "table") and ((_239_)[1] == "base") and ((_239_)[2] == 92)) then + local _233_0 = {state, b} + if ((_G.type(_233_0) == "table") and (_233_0[1] == "base") and (_233_0[2] == 92)) then state0 = "backslash" - elseif ((_G.type(_239_) == "table") and ((_239_)[1] == "base") and ((_239_)[2] == 34)) then + elseif ((_G.type(_233_0) == "table") and (_233_0[1] == "base") and (_233_0[2] == 34)) then state0 = "done" - elseif ((_G.type(_239_) == "table") and ((_239_)[1] == "backslash") and ((_239_)[2] == 10)) then + elseif ((_G.type(_233_0) == "table") and (_233_0[1] == "backslash") and (_233_0[2] == 10)) then table.remove(chars, (#chars - 1)) state0 = "base" - elseif true then - local _ = _239_ - state0 = "base" else - state0 = nil + local _ = _233_0 + state0 = "base" end end if (b and (state0 ~= "done")) then @@ -4066,39 +3956,34 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end end local function escape_char(c) - return ({[7] = "\\a", [8] = "\\b", [9] = "\\t", [10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r"})[c:byte()] + return ({[10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r", [7] = "\\a", [8] = "\\b", [9] = "\\t"})[c:byte()] end local function parse_string() table.insert(stack, {closer = 34}) local chars = {34} if not parse_string_loop(chars, getb(), "base") then badend("string") - else end table.remove(stack) local raw = string.char(unpack(chars)) local formatted = raw:gsub("[\7-\13]", escape_char) - local _243_ = (rawget(_G, "loadstring") or load)(("return " .. formatted)) - if (nil ~= _243_) then - local load_fn = _243_ + local _237_0 = (rawget(_G, "loadstring") or load)(("return " .. formatted)) + if (nil ~= _237_0) then + local load_fn = _237_0 return dispatch(load_fn()) - elseif (_243_ == nil) then + elseif (_237_0 == nil) then return parse_error(("Invalid string: " .. raw)) - else - return nil end end local function parse_prefix(b) - table.insert(stack, {prefix = prefixes[b], filename = filename, line = line, bytestart = byteindex, col = (col - 1)}) + table.insert(stack, {bytestart = byteindex, col = (col - 1), filename = filename, line = line, prefix = prefixes[b]}) local nextb = getb() if (whitespace_3f(nextb) or (true == delims[nextb])) then if (b ~= 35) then parse_error("invalid whitespace after quoting prefix") - else end table.remove(stack) dispatch(utils.sym("#")) - else end return ungetb(nextb) end @@ -4109,7 +3994,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( else if b then ungetb(b) - else end return chars end @@ -4120,16 +4004,14 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\"")))) return true else - local _249_ = tonumber(number_with_stripped_underscores) - if (nil ~= _249_) then - local x = _249_ + local _243_0 = tonumber(number_with_stripped_underscores) + if (nil ~= _243_0) then + local x = _243_0 dispatch(x) return true - elseif true then - local _ = _249_ - return false else - return nil + local _ = _243_0 + return false end end end @@ -4147,12 +4029,11 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( parse_error(("malformed multisym: " .. rawstr), col_adjust(":$")) elseif rawstr:match(":.+[%.:]") then parse_error(("method must be last component of multisym: " .. rawstr), col_adjust(":.+[%.:]")) - else end return rawstr end local function parse_sym(b) - local source0 = {bytestart = byteindex, filename = filename, line = line, col = (col - 1)} + local source0 = {bytestart = byteindex, col = (col - 1), filename = filename, line = line} local rawstr = string.char(unpack(parse_sym_loop({b}, getb()))) set_source_fields(source0) if (rawstr == "true") then @@ -4165,8 +4046,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return dispatch(rawstr:sub(2)) elseif not parse_number(rawstr) then return dispatch(utils.sym(check_malformed_sym(rawstr), source0)) - else - return nil end end local function parse_loop(b) @@ -4185,7 +4064,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( parse_sym(b) elseif not utils["hook-opts"]("illegal-char", options, b, getb, ungetb, dispatch) then parse_error(("invalid character: " .. string.char(b))) - else end if not b then return nil @@ -4197,69 +4075,112 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return parse_loop(skip_whitespace(getb())) end - local function _256_() + local function _250_() stack, line, byteindex, col, lastb = {}, 1, 0, 0, nil return nil end - return parse_stream, _256_ + return parse_stream, _250_ end local function parser(stream_or_string, _3ffilename, _3foptions) local filename = (_3ffilename or "unknown") local options = (_3foptions or utils.root.options or {}) assert(("string" == type(filename)), "expected filename as second argument to parser") if ("string" == type(stream_or_string)) then - return parser_fn(string_stream(stream_or_string), filename, options) + return parser_fn(string_stream(stream_or_string, options), filename, options) else return parser_fn(stream_or_string, filename, options) end end - return {granulate = granulate, parser = parser, ["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f} + return {["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f, granulate = granulate, parser = parser} end package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) - local type_order = {number = 1, boolean = 2, string = 3, table = 4, ["function"] = 5, userdata = 6, thread = 7} + local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6} + local default_opts = {["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["escape-newlines?"] = false, ["line-length"] = 80, ["max-sparse-gap"] = 10, ["metamethod?"] = true, ["one-line?"] = false, ["prefer-colon?"] = false, ["utf8?"] = true, depth = 128} local lua_pairs = pairs local lua_ipairs = ipairs local function pairs(t) - local _1_ = getmetatable(t) - if ((_G.type(_1_) == "table") and (nil ~= (_1_).__pairs)) then - local p = (_1_).__pairs + local _1_0 = getmetatable(t) + if ((_G.type(_1_0) == "table") and (nil ~= _1_0.__pairs)) then + local p = _1_0.__pairs return p(t) - elseif true then - local _ = _1_ - return lua_pairs(t) else - return nil + local _ = _1_0 + return lua_pairs(t) end end local function ipairs(t) - local _3_ = getmetatable(t) - if ((_G.type(_3_) == "table") and (nil ~= (_3_).__ipairs)) then - local i = (_3_).__ipairs + local _3_0 = getmetatable(t) + if ((_G.type(_3_0) == "table") and (nil ~= _3_0.__ipairs)) then + local i = _3_0.__ipairs return i(t) - elseif true then - local _ = _3_ - return lua_ipairs(t) else - return nil + local _ = _3_0 + return lua_ipairs(t) end end local function length_2a(t) - local _5_ = getmetatable(t) - if ((_G.type(_5_) == "table") and (nil ~= (_5_).__len)) then - local l = (_5_).__len + local _5_0 = getmetatable(t) + if ((_G.type(_5_0) == "table") and (nil ~= _5_0.__len)) then + local l = _5_0.__len return l(t) - elseif true then - local _ = _5_ - return #t else - return nil + local _ = _5_0 + return #t end end - local function sort_keys(_7_, _9_) - local _arg_8_ = _7_ - local a = _arg_8_[1] - local _arg_10_ = _9_ - local b = _arg_10_[1] + local function get_default(key) + local _7_0 = default_opts[key] + if (_7_0 == nil) then + return error(("option '%s' doesn't have a default value, use the :after key to set it"):format(tostring(key))) + elseif (nil ~= _7_0) then + local v = _7_0 + return v + end + end + local function getopt(options, key) + local val = options[key] + local _9_0 = val + if ((_G.type(_9_0) == "table") and (nil ~= _9_0.once)) then + local val_2a = _9_0.once + return val_2a + else + local _ = _9_0 + return val + end + end + local function normalize_opts(options) + local tbl_14_ = {} + for k, v in pairs(options) do + local k_15_, v_16_ = nil, nil + local function _12_() + local _11_0 = v + if ((_G.type(_11_0) == "table") and (nil ~= _11_0.after)) then + local val = _11_0.after + return val + else + local function _13_() + return v.once + end + if ((_G.type(_11_0) == "table") and _13_()) then + return get_default(k) + else + local _ = _11_0 + return v + end + end + end + k_15_, v_16_ = k, _12_() + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end + end + return tbl_14_ + end + local function sort_keys(_16_0, _18_0) + local _17_ = _16_0 + local a = _17_[1] + local _19_ = _18_0 + local b = _19_[1] local ta = type(a) local tb = type(b) if ((ta == tb) and ((ta == "string") or (ta == "number"))) then @@ -4282,25 +4203,23 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local gap = 0 if (0 < length_2a(kv)) then local i = 0 - for _, _13_ in ipairs(kv) do - local _each_14_ = _13_ - local k = _each_14_[1] + for _, _22_0 in ipairs(kv) do + local _23_ = _22_0 + local k = _23_[1] if (gap < (k - i)) then gap = (k - i) - else end i = k end - else end return gap end local function fill_gaps(kv) local missing_indexes = {} local i = 0 - for _, _17_ in ipairs(kv) do - local _each_18_ = _17_ - local j = _each_18_[1] + for _, _26_0 in ipairs(kv) do + local _27_ = _26_0 + local j = _27_[1] i = (i + 1) while (i < j) do table.insert(missing_indexes, i) @@ -4319,7 +4238,6 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) for k, v in pairs(t) do if ((type(k) ~= "number") or (k < 1)) then assoc_3f = true - else end insert(kv, {k, v}) end @@ -4330,19 +4248,18 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else fill_gaps(kv) end - else end if (length_2a(kv) == 0) then return kv, "empty" else - local function _22_() + local function _31_() if assoc_3f then return "table" else return "seq" end end - return kv, _22_() + return kv, _31_() end end local function count_table_appearances(t, appearances) @@ -4356,40 +4273,34 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else appearances[t] = ((appearances[t] or 0) + 1) end - else end return appearances end local function save_table(t, seen) local seen0 = (seen or {len = 0}) local id = (seen0.len + 1) - if not (seen0)[t] then + if not seen0[t] then seen0[t] = id seen0.len = id - else end return seen0 end local function detect_cycle(t, seen, _3fk) if ("table" == type(t)) then seen[t] = true - local _27_, _28_ = next(t, _3fk) - if ((nil ~= _27_) and (nil ~= _28_)) then - local k = _27_ - local v = _28_ + local _36_0, _37_0 = next(t, _3fk) + if ((nil ~= _36_0) and (nil ~= _37_0)) then + local k = _36_0 + local v = _37_0 return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k)) - else - return nil end - else - return nil end end local function visible_cycle_3f(t, options) - return (options["detect-cycles?"] and detect_cycle(t, {}) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) + return (getopt(options, "detect-cycles?") and detect_cycle(t, {}) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) end local function table_indent(indent, id) - local opener_length + local opener_length = nil if id then opener_length = (length_2a(tostring(id)) + 2) else @@ -4400,31 +4311,31 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local pp = nil local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix, last_comment_3f) local indent_str = ("\n" .. string.rep(" ", indent)) - local open - local function _32_() + local open = nil + local function _41_() if ("seq" == table_type) then return "[" else return "{" end end - open = ((prefix or "") .. _32_()) - local close + open = ((prefix or "") .. _41_()) + local close = nil if ("seq" == table_type) then close = "]" else close = "}" end local oneline = (open .. table.concat(elements, " ") .. close) - if (not options["one-line?"] and (multiline_3f or (options["line-length"] < (indent + length_2a(oneline))) or last_comment_3f)) then - local function _34_() + if (not getopt(options, "one-line?") and (multiline_3f or (options["line-length"] < (indent + length_2a(oneline))) or last_comment_3f)) then + local function _43_() if last_comment_3f then return indent_str else return "" end end - return (open .. table.concat(elements, indent_str) .. _34_() .. close) + return (open .. table.concat(elements, indent_str) .. _43_() .. close) else return oneline end @@ -4449,49 +4360,49 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local id = options.seen[t] if (options.depth <= options.level) then return "{...}" - elseif (id and options["detect-cycles?"]) then + elseif (id and getopt(options, "detect-cycles?")) then return ("@" .. id .. "{...}") else local visible_cycle_3f0 = visible_cycle_3f(t, options) local id0 = (visible_cycle_3f0 and options.seen[t]) local indent0 = table_indent(indent, id0) - local slength - if options["utf8?"] then + local slength = nil + if getopt(options, "utf8?") then slength = utf8_len else - local function _37_(_241) + local function _46_(_241) return #_241 end - slength = _37_ + slength = _46_ end - local prefix + local prefix = nil if visible_cycle_3f0 then prefix = ("@" .. id0) else prefix = "" end - local items + local items = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for _, _40_ in ipairs(kv) do - local _each_41_ = _40_ - local k = _each_41_[1] - local v = _each_41_[2] - local val_16_auto + local options0 = normalize_opts(options) + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _49_0 in ipairs(kv) do + local _50_ = _49_0 + local k = _50_[1] + local v = _50_[2] + local val_19_ = nil do - local k0 = pp(k, options, (indent0 + 1), true) - local v0 = pp(v, options, (indent0 + slength(k0) + 1)) + local k0 = pp(k, options0, (indent0 + 1), true) + local v0 = pp(v, options0, (indent0 + slength(k0) + 1)) multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) - val_16_auto = (k0 .. " " .. v0) + val_19_ = (k0 .. " " .. v0) end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - items = tbl_14_auto + items = tbl_17_ end return concat_table_lines(items, options, multiline_3f, indent0, "table", prefix, false) end @@ -4501,69 +4412,68 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local id = options.seen[t] if (options.depth <= options.level) then return "[...]" - elseif (id and options["detect-cycles?"]) then + elseif (id and getopt(options, "detect-cycles?")) then return ("@" .. id .. "[...]") else local visible_cycle_3f0 = visible_cycle_3f(t, options) local id0 = (visible_cycle_3f0 and options.seen[t]) local indent0 = table_indent(indent, id0) - local prefix + local prefix = nil if visible_cycle_3f0 then prefix = ("@" .. id0) else prefix = "" end local last_comment_3f = comment_3f(t[#t]) - local items + local items = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for _, _45_ in ipairs(kv) do - local _each_46_ = _45_ - local _0 = _each_46_[1] - local v = _each_46_[2] - local val_16_auto + local options0 = normalize_opts(options) + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _54_0 in ipairs(kv) do + local _55_ = _54_0 + local _0 = _55_[1] + local v = _55_[2] + local val_19_ = nil do - local v0 = pp(v, options, indent0) + local v0 = pp(v, options0, indent0) multiline_3f = (multiline_3f or v0:find("\n") or v0:find("^;")) - val_16_auto = v0 + val_19_ = v0 end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - items = tbl_14_auto + items = tbl_17_ end return concat_table_lines(items, options, multiline_3f, indent0, "seq", prefix, last_comment_3f) end end local function concat_lines(lines, options, indent, force_multi_line_3f) if (length_2a(lines) == 0) then - if options["empty-as-sequence?"] then + if getopt(options, "empty-as-sequence?") then return "[]" else return "{}" end else - local oneline - local _50_ + local oneline = nil + local _59_ do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, line in ipairs(lines) do - local val_16_auto = line:gsub("^%s+", "") - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = line:gsub("^%s+", "") + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _50_ = tbl_14_auto + _59_ = tbl_17_ end - oneline = table.concat(_50_, " ") - if (not options["one-line?"] and (force_multi_line_3f or oneline:find("\n") or (options["line-length"] < (indent + length_2a(oneline))))) then + oneline = table.concat(_59_, " ") + if (not getopt(options, "one-line?") and (force_multi_line_3f or oneline:find("\n") or (options["line-length"] < (indent + length_2a(oneline))))) then return table.concat(lines, ("\n" .. string.rep(" ", indent))) else return oneline @@ -4572,106 +4482,106 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end local function pp_metamethod(t, metamethod, options, indent) if (options.depth <= options.level) then - if options["empty-as-sequence?"] then + if getopt(options, "empty-as-sequence?") then return "[...]" else return "{...}" end else - local _ - local function _55_(_241) + local _ = nil + local function _64_(_241) return visible_cycle_3f(_241, options) end - options["visible-cycle?"] = _55_ + options["visible-cycle?"] = _64_ _ = nil - local lines, force_multi_line_3f = metamethod(t, pp, options, indent) + local lines, force_multi_line_3f = nil, nil + do + local options0 = normalize_opts(options) + lines, force_multi_line_3f = metamethod(t, pp, options0, indent) + end options["visible-cycle?"] = nil - local _56_ = type(lines) - if (_56_ == "string") then + local _65_0 = type(lines) + if (_65_0 == "string") then return lines - elseif (_56_ == "table") then + elseif (_65_0 == "table") then return concat_lines(lines, options, indent, force_multi_line_3f) - elseif true then - local _0 = _56_ - return error("__fennelview metamethod must return a table of lines") else - return nil + local _0 = _65_0 + return error("__fennelview metamethod must return a table of lines") end end end local function pp_table(x, options, indent) options.level = (options.level + 1) - local x0 + local x0 = nil do - local _59_ - if options["metamethod?"] then - local _60_ = x - if (nil ~= _60_) then - local _61_ = getmetatable(_60_) - if (nil ~= _61_) then - _59_ = (_61_).__fennelview + local _68_0 = nil + if getopt(options, "metamethod?") then + local _69_0 = x + if (nil ~= _69_0) then + local _70_0 = getmetatable(_69_0) + if (nil ~= _70_0) then + _68_0 = _70_0.__fennelview else - _59_ = _61_ + _68_0 = _70_0 end else - _59_ = _60_ + _68_0 = _69_0 end else - _59_ = nil + _68_0 = nil end - if (nil ~= _59_) then - local metamethod = _59_ + if (nil ~= _68_0) then + local metamethod = _68_0 x0 = pp_metamethod(x, metamethod, options, indent) - elseif true then - local _ = _59_ - local _65_, _66_ = table_kv_pairs(x, options) - if (true and (_66_ == "empty")) then - local _0 = _65_ - if options["empty-as-sequence?"] then + else + local _ = _68_0 + local _74_0, _75_0 = table_kv_pairs(x, options) + if (true and (_75_0 == "empty")) then + local _0 = _74_0 + if getopt(options, "empty-as-sequence?") then x0 = "[]" else x0 = "{}" end - elseif ((nil ~= _65_) and (_66_ == "table")) then - local kv = _65_ + elseif ((nil ~= _74_0) and (_75_0 == "table")) then + local kv = _74_0 x0 = pp_associative(x, kv, options, indent) - elseif ((nil ~= _65_) and (_66_ == "seq")) then - local kv = _65_ + elseif ((nil ~= _74_0) and (_75_0 == "seq")) then + local kv = _74_0 x0 = pp_sequence(x, kv, options, indent) else - x0 = nil - end - else x0 = nil + end end end options.level = (options.level - 1) return x0 end local function number__3estring(n) - local _70_ = string.gsub(tostring(n), ",", ".") - return _70_ + local _79_0 = string.gsub(tostring(n), ",", ".") + return _79_0 end local function colon_string_3f(s) return s:find("^[-%w?^_!$%&*+./@|<=>]+$") end - local utf8_inits = {{["min-byte"] = 0, ["max-byte"] = 127, ["min-code"] = 0, ["max-code"] = 127, len = 1}, {["min-byte"] = 192, ["max-byte"] = 223, ["min-code"] = 128, ["max-code"] = 2047, len = 2}, {["min-byte"] = 224, ["max-byte"] = 239, ["min-code"] = 2048, ["max-code"] = 65535, len = 3}, {["min-byte"] = 240, ["max-byte"] = 247, ["min-code"] = 65536, ["max-code"] = 1114111, len = 4}} + local utf8_inits = {{["max-byte"] = 127, ["max-code"] = 127, ["min-byte"] = 0, ["min-code"] = 0, len = 1}, {["max-byte"] = 223, ["max-code"] = 2047, ["min-byte"] = 192, ["min-code"] = 128, len = 2}, {["max-byte"] = 239, ["max-code"] = 65535, ["min-byte"] = 224, ["min-code"] = 2048, len = 3}, {["max-byte"] = 247, ["max-code"] = 1114111, ["min-byte"] = 240, ["min-code"] = 65536, len = 4}} local function utf8_escape(str) local function validate_utf8(str0, index) local inits = utf8_inits local byte = string.byte(str0, index) - local init + local init = nil do local ret = nil for _, init0 in ipairs(inits) do if ret then break end - ret = (byte and (function(_71_,_72_,_73_) return (_71_ <= _72_) and (_72_ <= _73_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) + ret = (byte and (function(_80_,_81_,_82_) return (_80_ <= _81_) and (_81_ <= _82_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) end init = ret end - local code - local function _74_() - local code0 + local code = nil + local function _83_() + local code0 = nil if init then code0 = (byte - init["min-byte"]) else @@ -4679,15 +4589,13 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end for i = (index + 1), (index + init.len + -1) do local byte0 = string.byte(str0, i) - code0 = (byte0 and code0 and (function(_76_,_77_,_78_) return (_76_ <= _77_) and (_77_ <= _78_) end)(128,byte0,191) and ((code0 * 64) + (byte0 - 128))) + code0 = (byte0 and code0 and ((128 <= byte0) and (byte0 <= 191)) and ((code0 * 64) + (byte0 - 128))) end return code0 end - code = (init and _74_()) - if (code and (function(_79_,_80_,_81_) return (_79_ <= _80_) and (_80_ <= _81_) end)(init["min-code"],code,init["max-code"]) and not (function(_82_,_83_,_84_) return (_82_ <= _83_) and (_83_ <= _84_) end)(55296,code,57343)) then + code = (init and _83_()) + if (code and (function(_85_,_86_,_87_) return (_85_ <= _86_) and (_86_ <= _87_) end)(init["min-code"],code,init["max-code"]) and not ((55296 <= code) and (code <= 57343))) then return init.len - else - return nil end end local index = 1 @@ -4698,7 +4606,6 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) table.insert(output, string.sub(str, index, (nexti + (len or 0) + -1))) if (not len and (nexti <= #str)) then table.insert(output, string.format("\\%03d", string.byte(str, nexti))) - else end if len then index = (nexti + len) @@ -4709,27 +4616,39 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return table.concat(output) end local function pp_string(str, options, indent) - local escs - local _88_ - if (options["escape-newlines?"] and (length_2a(str) < (options["line-length"] - indent))) then - _88_ = "\\n" + local len = length_2a(str) + local esc_newline_3f = ((len < 2) or (getopt(options, "escape-newlines?") and (len < (options["line-length"] - indent)))) + local escs = nil + local _91_ + if esc_newline_3f then + _91_ = "\\n" else - _88_ = "\n" + _91_ = "\n" end - local function _90_(_241, _242) + local function _93_(_241, _242) return ("\\%03d"):format(_242:byte()) end - escs = setmetatable({["\7"] = "\\a", ["\8"] = "\\b", ["\12"] = "\\f", ["\11"] = "\\v", ["\13"] = "\\r", ["\9"] = "\\t", ["\\"] = "\\\\", ["\""] = "\\\"", ["\n"] = _88_}, {__index = _90_}) + escs = setmetatable({["\""] = "\\\"", ["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\\"] = "\\\\", ["\n"] = _91_}, {__index = _93_}) local str0 = ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"") - if options["utf8?"] then + if getopt(options, "utf8?") then return utf8_escape(str0) else return str0 end end local function make_options(t, options) - local defaults = {["line-length"] = 80, ["one-line?"] = false, depth = 128, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["metamethod?"] = true, ["prefer-colon?"] = false, ["escape-newlines?"] = false, ["utf8?"] = true, ["max-sparse-gap"] = 10} - local overrides = {level = 0, appearances = count_table_appearances(t, {}), seen = {len = 0}} + local defaults = nil + do + local tbl_14_ = {} + for k, v in pairs(default_opts) do + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end + end + defaults = tbl_14_ + end + local overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}} for k, v in pairs((options or {})) do defaults[k] = v end @@ -4738,39 +4657,39 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return defaults end - local function _92_(x, options, indent, colon_3f) + local function _96_(x, options, indent, colon_3f) local indent0 = (indent or 0) local options0 = (options or make_options(x)) - local x0 + local x0 = nil if options0.preprocess then x0 = options0.preprocess(x, options0) else x0 = x end local tv = type(x0) - local function _95_() - local _94_ = getmetatable(x0) - if (nil ~= _94_) then - return (_94_).__fennelview + local function _99_() + local _98_0 = getmetatable(x0) + if (nil ~= _98_0) then + return _98_0.__fennelview else - return _94_ + return _98_0 end end - if ((tv == "table") or ((tv == "userdata") and _95_())) then + if ((tv == "table") or ((tv == "userdata") and _99_())) then return pp_table(x0, options0, indent0) elseif (tv == "number") then return number__3estring(x0) else - local function _97_() + local function _101_() if (colon_3f ~= nil) then return colon_3f elseif ("function" == type(options0["prefer-colon?"])) then return options0["prefer-colon?"](x0) else - return options0["prefer-colon?"] + return getopt(options0, "prefer-colon?") end end - if ((tv == "string") and colon_string_3f(x0) and _97_()) then + if ((tv == "string") and colon_string_3f(x0) and _101_()) then return (":" .. x0) elseif (tv == "string") then return pp_string(x0, options0, indent0) @@ -4781,7 +4700,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end end end - pp = _92_ + pp = _96_ local function view(x, _3foptions) return pp(x, make_options(x, _3foptions), 0) end @@ -4789,12 +4708,12 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...) local view = require("fennel.view") - local version = "1.3.0-dev" + local version = "1.3.1-dev" local function luajit_vm_3f() return ((nil ~= _G.jit) and (type(_G.jit) == "table") and (nil ~= _G.jit.on) and (nil ~= _G.jit.off) and (type(_G.jit.version_num) == "number")) end local function luajit_vm_version() - local jit_os + local jit_os = nil if (_G.jit.os == "OSX") then jit_os = "macOS" else @@ -4823,21 +4742,17 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function warn(message) if (_G.io and _G.io.stderr) then return (_G.io.stderr):write(("--WARNING: %s\n"):format(tostring(message))) - else - return nil end end - local len + local len = nil do - local _102_, _103_ = pcall(require, "utf8") - if ((_102_ == true) and (nil ~= _103_)) then - local utf8 = _103_ + local _106_0, _107_0 = pcall(require, "utf8") + if ((_106_0 == true) and (nil ~= _107_0)) then + local utf8 = _107_0 len = utf8.len - elseif true then - local _ = _102_ - len = string.len else - len = nil + local _ = _106_0 + len = string.len end end local function mt_keys_in_order(t, out, used_keys) @@ -4845,67 +4760,60 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. if (t[k] and not used_keys[k]) then used_keys[k] = true table.insert(out, k) - else end end for k in pairs(t) do if not used_keys[k] then table.insert(out, k) - else end end return out end local function stablepairs(t) - local keys - local _108_ + local keys = nil + local _112_ do - local t_107_ = getmetatable(t) - if (nil ~= t_107_) then - t_107_ = (t_107_).keys - else + local _111_0 = getmetatable(t) + if (nil ~= _111_0) then + _111_0 = _111_0.keys end - _108_ = t_107_ + _112_ = _111_0 end - if _108_ then + if _112_ then keys = mt_keys_in_order(t, {}, {}) else - local _110_ + local _114_0 = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for k in pairs(t) do - local val_16_auto = k - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = k + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _110_ = tbl_14_auto + _114_0 = tbl_17_ end - local function _112_(_241, _242) + local function _116_(_241, _242) return (tostring(_241) < tostring(_242)) end - table.sort(_110_, _112_) - keys = _110_ + table.sort(_114_0, _116_) + keys = _114_0 end - local succ + local succ = nil do - local tbl_11_auto = {} + local tbl_14_ = {} for i, k in ipairs(keys) do - local _114_, _115_ = k, keys[(i + 1)] - if ((nil ~= _114_) and (nil ~= _115_)) then - local k_12_auto = _114_ - local v_13_auto = _115_ - tbl_11_auto[k_12_auto] = v_13_auto - else + local k_15_, v_16_ = k, keys[(i + 1)] + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - succ = tbl_11_auto + succ = tbl_14_ end local function stablenext(tbl, key) - local next_key + local next_key = nil if (key == nil) then next_key = keys[1] else @@ -4920,103 +4828,113 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. if (0 == #path) then return _3ffallback else - local _118_ + local _120_0 = nil do local t = tbl for _, k in ipairs(path) do if (nil == t) then break end - local _119_ = type(t) - if (_119_ == "table") then + local _121_0 = type(t) + if (_121_0 == "table") then t = t[k] else - t = nil + t = nil end end - _118_ = t + _120_0 = t end - if (nil ~= _118_) then - local res = _118_ + if (nil ~= _120_0) then + local res = _120_0 return res - elseif true then - local _ = _118_ - return _3ffallback else - return nil + local _ = _120_0 + return _3ffallback end end end local function map(t, f, _3fout) local out = (_3fout or {}) - local f0 + local f0 = nil if (type(f) == "function") then f0 = f else - local function _123_(_241) - return (_241)[f] + local function _125_(_241) + return _241[f] end - f0 = _123_ + f0 = _125_ end for _, x in ipairs(t) do - local _125_ = f0(x) - if (nil ~= _125_) then - local v = _125_ + local _127_0 = f0(x) + if (nil ~= _127_0) then + local v = _127_0 table.insert(out, v) - else end end return out end local function kvmap(t, f, _3fout) local out = (_3fout or {}) - local f0 + local f0 = nil if (type(f) == "function") then f0 = f else - local function _127_(_241) - return (_241)[f] + local function _129_(_241) + return _241[f] end - f0 = _127_ + f0 = _129_ end for k, x in stablepairs(t) do - local _129_, _130_ = f0(k, x) - if ((nil ~= _129_) and (nil ~= _130_)) then - local key = _129_ - local value = _130_ + local _131_0, _132_0 = f0(k, x) + if ((nil ~= _131_0) and (nil ~= _132_0)) then + local key = _131_0 + local value = _132_0 out[key] = value - elseif (nil ~= _129_) then - local value = _129_ + elseif (nil ~= _131_0) then + local value = _131_0 table.insert(out, value) - else end end return out end local function copy(from, _3fto) - local tbl_11_auto = (_3fto or {}) + local tbl_14_ = (_3fto or {}) for k, v in pairs((from or {})) do - local _132_, _133_ = k, v - if ((nil ~= _132_) and (nil ~= _133_)) then - local k_12_auto = _132_ - local v_13_auto = _133_ - tbl_11_auto[k_12_auto] = v_13_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - return tbl_11_auto + return tbl_14_ end local function member_3f(x, tbl, _3fn) - local _135_ = tbl[(_3fn or 1)] - if (_135_ == x) then + local _135_0 = tbl[(_3fn or 1)] + if (_135_0 == x) then return true - elseif (_135_ == nil) then + elseif (_135_0 == nil) then return nil - elseif true then - local _ = _135_ - return member_3f(x, tbl, ((_3fn or 1) + 1)) else - return nil + local _ = _135_0 + return member_3f(x, tbl, ((_3fn or 1) + 1)) end end + local function maxn(tbl) + local max = 0 + for k in pairs(tbl) do + if ("number" == type(k)) then + max = math.max(max, k) + else + max = max + end + end + return max + end + local function every_3f(t, predicate) + local result = true + for _, item in ipairs(t) do + if not result then break end + result = predicate(item) + end + return result + end local function allpairs(tbl) assert((type(tbl) == "table"), "allpairs expects a table") local t = tbl @@ -5029,17 +4947,13 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. seen[next_state] = true return next_state, value else - local _137_ = getmetatable(t) - if ((_G.type(_137_) == "table") and true) then - local __index = (_137_).__index + local _138_0 = getmetatable(t) + if ((_G.type(_138_0) == "table") and true) then + local __index = _138_0.__index if ("table" == type(__index)) then t = __index return allpairs_next(t) - else - return nil end - else - return nil end end end @@ -5049,19 +4963,22 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return self[1] end local nil_sym = nil - local function list__3estring(self, _3ftostring2) + local function list__3estring(self, _3fview, _3foptions, _3findent) local safe = {} - local max = 0 - for k in pairs(self) do - if ((type(k) == "number") and (max < k)) then - max = k - else + local view0 = nil + if _3fview then + local function _142_(_241) + return _3fview(_241, _3foptions, _3findent) end + view0 = _142_ + else + view0 = view end + local max = maxn(self) for i = 1, max do safe[i] = (((self[i] == nil) and nil_sym) or self[i]) end - return ("(" .. table.concat(map(safe, (_3ftostring2 or view)), " ", 1, max) .. ")") + return ("(" .. table.concat(map(safe, view0), " ", 1, max) .. ")") end local function comment_view(c) return c, true @@ -5072,21 +4989,21 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function sym_3c(a, b) return (a[1] < tostring(b)) end - local symbol_mt = {__fennelview = deref, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "SYMBOL"} - local expr_mt - local function _142_(x) + local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref} + local expr_mt = nil + local function _144_(x) return tostring(deref(x)) end - expr_mt = {__tostring = _142_, "EXPR"} - local list_mt = {__fennelview = list__3estring, __tostring = list__3estring, "LIST"} - local comment_mt = {__fennelview = comment_view, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "COMMENT"} + expr_mt = {"EXPR", __tostring = _144_} + local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring} + local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref} local sequence_marker = {"SEQUENCE"} - local varg_mt = {__fennelview = deref, __tostring = deref, "VARARG"} - local getenv - local function _143_() + local varg_mt = {"VARARG", __fennelview = deref, __tostring = deref} + local getenv = nil + local function _145_() return nil end - getenv = ((os and os.getenv) or _143_) + getenv = ((os and os.getenv) or _145_) local function debug_on_3f(flag) local level = (getenv("FENNEL_DEBUG") or "") return ((level == "all") or level:find(flag)) @@ -5095,61 +5012,64 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return setmetatable({...}, list_mt) end local function sym(str, _3fsource) - local _144_ + local _146_ do - local tbl_11_auto = {str} + local tbl_14_ = {str} for k, v in pairs((_3fsource or {})) do - local _145_, _146_ = nil, nil + local k_15_, v_16_ = nil, nil if (type(k) == "string") then - _145_, _146_ = k, v + k_15_, v_16_ = k, v else - _145_, _146_ = nil + k_15_, v_16_ = nil end - if ((nil ~= _145_) and (nil ~= _146_)) then - local k_12_auto = _145_ - local v_13_auto = _146_ - tbl_11_auto[k_12_auto] = v_13_auto - else + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _144_ = tbl_11_auto + _146_ = tbl_14_ end - return setmetatable(_144_, symbol_mt) + return setmetatable(_146_, symbol_mt) end nil_sym = sym("nil") local function sequence(...) - return setmetatable({...}, {sequence = sequence_marker}) + local function _149_(seq, view0, inspector, indent) + local opts = nil + do + inspector["empty-as-sequence?"] = {after = inspector["empty-as-sequence?"], once = true} + inspector["metamethod?"] = {after = inspector["metamethod?"], once = false} + opts = inspector + end + return view0(seq, opts, indent) + end + return setmetatable({...}, {__fennelview = _149_, sequence = sequence_marker}) end local function expr(strcode, etype) - return setmetatable({type = etype, strcode}, expr_mt) + return setmetatable({strcode, type = etype}, expr_mt) end local function comment_2a(contents, _3fsource) - local _let_149_ = (_3fsource or {}) - local filename = _let_149_["filename"] - local line = _let_149_["line"] - return setmetatable({filename = filename, line = line, contents}, comment_mt) + local _150_ = (_3fsource or {}) + local filename = _150_["filename"] + local line = _150_["line"] + return setmetatable({contents, filename = filename, line = line}, comment_mt) end local function varg(_3fsource) - local _150_ + local _151_ do - local tbl_11_auto = {"..."} + local tbl_14_ = {"..."} for k, v in pairs((_3fsource or {})) do - local _151_, _152_ = nil, nil + local k_15_, v_16_ = nil, nil if (type(k) == "string") then - _151_, _152_ = k, v + k_15_, v_16_ = k, v else - _151_, _152_ = nil + k_15_, v_16_ = nil end - if ((nil ~= _151_) and (nil ~= _152_)) then - local k_12_auto = _151_ - local v_13_auto = _152_ - tbl_11_auto[k_12_auto] = v_13_auto - else + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _150_ = tbl_11_auto + _151_ = tbl_14_ end - return setmetatable(_150_, varg_mt) + return setmetatable(_151_, varg_mt) end local function expr_3f(x) return ((type(x) == "table") and (getmetatable(x) == expr_mt) and x) @@ -5182,25 +5102,30 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. elseif (type(str) ~= "string") then return false else - local parts = {} - for part in str:gmatch("[^%.%:]+[%.%:]?") do - local last_char = part:sub(( - 1)) - if (last_char == ":") then - parts["multi-sym-method-call"] = true - else - end - if ((last_char == ":") or (last_char == ".")) then - parts[(#parts + 1)] = part:sub(1, ( - 2)) - else - parts[(#parts + 1)] = part + local function _154_() + local parts = {} + for part in str:gmatch("[^%.%:]+[%.%:]?") do + local last_char = part:sub(( - 1)) + if (last_char == ":") then + parts["multi-sym-method-call"] = true + end + if ((last_char == ":") or (last_char == ".")) then + parts[(#parts + 1)] = part:sub(1, ( - 2)) + else + parts[(#parts + 1)] = part + end end + return ((0 < #parts) and parts) end - return ((0 < #parts) and (str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte(( - 1)) ~= string.byte(".")) and parts) + return ((str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte(( - 1)) ~= string.byte(".")) and _154_()) end end local function quoted_3f(symbol) return symbol.quoted end + local function idempotent_expr_3f(x) + return ((type(x) == "string") or (type(x) == "integer") or (type(x) == "number") or (sym_3f(x) and not multi_sym_3f(x))) + end local function ast_source(ast) if (table_3f(ast) or sequence_3f(ast)) then return (getmetatable(ast) or {}) @@ -5217,8 +5142,6 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. walk(iterfn, node, k, v) end return nil - else - return nil end end walk((_3fcustom_iterator or pairs), nil, nil, root) @@ -5238,16 +5161,16 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. end return subopts end - local root + local root = nil local function _160_() end - root = {chunk = nil, scope = nil, options = nil, reset = _160_} - root["set-reset"] = function(_161_) - local _arg_162_ = _161_ - local chunk = _arg_162_["chunk"] - local scope = _arg_162_["scope"] - local options = _arg_162_["options"] - local reset = _arg_162_["reset"] + root = {chunk = nil, options = nil, reset = _160_, scope = nil} + root["set-reset"] = function(_161_0) + local _162_ = _161_0 + local chunk = _162_["chunk"] + local options = _162_["options"] + local reset = _162_["reset"] + local scope = _162_["scope"] root.reset = function() root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset return nil @@ -5255,35 +5178,31 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return root.reset end local warned = {} - local function check_plugin_version(_163_) - local _arg_164_ = _163_ - local name = _arg_164_["name"] - local versions = _arg_164_["versions"] - local plugin = _arg_164_ + local function check_plugin_version(_163_0) + local _164_ = _163_0 + local plugin = _164_ + local name = _164_["name"] + local versions = _164_["versions"] if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not warned[plugin]) then warned[plugin] = true return warn(string.format("plugin %s does not support Fennel version %s", (name or "unknown"), version)) - else - return nil end end local function hook_opts(event, _3foptions, ...) - local plugins + local plugins = nil local function _167_(...) - local t_166_ = _3foptions - if (nil ~= t_166_) then - t_166_ = (t_166_).plugins - else + local _166_0 = _3foptions + if (nil ~= _166_0) then + _166_0 = _166_0.plugins end - return t_166_ + return _166_0 end local function _170_(...) - local t_169_ = root.options - if (nil ~= t_169_) then - t_169_ = (t_169_).plugins - else + local _169_0 = root.options + if (nil ~= _169_0) then + _169_0 = _169_0.plugins end - return t_169_ + return _169_0 end plugins = (_167_(...) or _170_(...)) if plugins then @@ -5291,23 +5210,21 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. for _, plugin in ipairs(plugins) do if result then break end check_plugin_version(plugin) - local _172_ = plugin[event] - if (nil ~= _172_) then - local f = _172_ + local _172_0 = plugin[event] + if (nil ~= _172_0) then + local f = _172_0 result = f(...) else - result = nil + result = nil end end return result - else - return nil end end local function hook(event, ...) return hook_opts(event, root.options, ...) end - return {warn = warn, allpairs = allpairs, stablepairs = stablepairs, copy = copy, ["get-in"] = get_in, kvmap = kvmap, map = map, ["walk-tree"] = walk_tree, ["member?"] = member_3f, list = list, sequence = sequence, sym = sym, varg = varg, expr = expr, comment = comment_2a, ["comment?"] = comment_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["multi-sym?"] = multi_sym_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["varg?"] = varg_3f, ["quoted?"] = quoted_3f, ["string?"] = string_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["lua-keywords"] = lua_keywords, hook = hook, ["hook-opts"] = hook_opts, ["propagate-options"] = propagate_options, root = root, ["debug-on?"] = debug_on_3f, ["ast-source"] = ast_source, version = version, ["runtime-version"] = runtime_version, len = len, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";")} + return {["ast-source"] = ast_source, ["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["every?"] = every_3f, ["expr?"] = expr_3f, ["get-in"] = get_in, ["hook-opts"] = hook_opts, ["idempotent-expr?"] = idempotent_expr_3f, ["list?"] = list_3f, ["lua-keywords"] = lua_keywords, ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";"), ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["runtime-version"] = runtime_version, ["sequence?"] = sequence_3f, ["string?"] = string_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, expr = expr, hook = hook, kvmap = kvmap, len = len, list = list, map = map, maxn = maxn, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg, version = version, warn = warn} end package.preload["fennel"] = package.preload["fennel"] or function(...) local utils = require("fennel.utils") @@ -5321,7 +5238,6 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}, opts) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](env0) - else end return specials["wrap-env"](env0) else @@ -5332,15 +5248,12 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) local opts = utils.copy(options) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](opts.env) - else end if (not opts.filename and not opts.source) then opts.source = str - else end if (opts.env == "_COMPILER") then opts.scope = compiler["make-scope"](compiler.scopes.compiler) - else end return opts end @@ -5348,15 +5261,15 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) local opts = eval_opts(options, str) local env = eval_env(opts.env, opts) local lua_source = compiler["compile-string"](str, opts) - local loader - local function _737_(...) + local loader = nil + local function _709_(...) if opts.filename then return ("@" .. opts.filename) else return str end end - loader = specials["load-code"](lua_source, env, _737_(...)) + loader = specials["load-code"](lua_source, env, _709_(...)) opts.filename = nil return loader(...) end @@ -5369,35 +5282,33 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) return eval(source, opts, ...) end local function syntax() - local body_3f = {"when", "with-open", "collect", "icollect", "fcollect", "lambda", "\206\187", "macro", "match", "matchless", "match-try", "accumulate", "doto"} - local binding_3f = {"collect", "icollect", "fcollect", "each", "for", "let", "with-open", "accumulate"} + local body_3f = {"when", "with-open", "collect", "icollect", "fcollect", "lambda", "\206\187", "macro", "match", "match-try", "case", "case-try", "accumulate", "faccumulate", "doto"} + local binding_3f = {"collect", "icollect", "fcollect", "each", "for", "let", "with-open", "accumulate", "faccumulate"} local define_3f = {"fn", "lambda", "\206\187", "var", "local", "macro", "macros", "global"} local out = {} for k, v in pairs(compiler.scopes.global.specials) do local metadata = (compiler.metadata[v] or {}) - do end (out)[k] = {["special?"] = true, ["body-form?"] = metadata["fnl/body-form?"], ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} + out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = metadata["fnl/body-form?"], ["define?"] = utils["member?"](k, define_3f), ["special?"] = true} end for k, v in pairs(compiler.scopes.global.macros) do - out[k] = {["macro?"] = true, ["body-form?"] = utils["member?"](k, body_3f), ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} + out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = utils["member?"](k, body_3f), ["define?"] = utils["member?"](k, define_3f), ["macro?"] = true} end for k, v in pairs(_G) do - local _738_ = type(v) - if (_738_ == "function") then - out[k] = {["global?"] = true, ["function?"] = true} - elseif (_738_ == "table") then + local _710_0 = type(v) + if (_710_0 == "function") then + out[k] = {["function?"] = true, ["global?"] = true} + elseif (_710_0 == "table") then for k2, v2 in pairs(v) do if (("function" == type(v2)) and (k ~= "_G")) then out[(k .. "." .. k2)] = {["function?"] = true, ["global?"] = true} - else end end out[k] = {["global?"] = true} - else end end return out end - local mod = {list = utils.list, ["list?"] = utils["list?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], ["table?"] = utils["table?"], comment = utils.comment, ["comment?"] = utils["comment?"], varg = utils.varg, ["varg?"] = utils["varg?"], ["sym-char?"] = parser["sym-char?"], parser = parser.parser, compile = compiler.compile, ["compile-string"] = compiler["compile-string"], ["compile-stream"] = compiler["compile-stream"], eval = eval, repl = repl, view = view, dofile = dofile_2a, ["load-code"] = specials["load-code"], doc = specials.doc, metadata = compiler.metadata, traceback = compiler.traceback, version = utils.version, ["runtime-version"] = utils["runtime-version"], ["ast-source"] = utils["ast-source"], path = utils.path, ["macro-path"] = utils["macro-path"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["search-module"] = specials["search-module"], ["make-searcher"] = specials["make-searcher"], searcher = specials["make-searcher"](), syntax = syntax, gensym = compiler.gensym, scope = compiler["make-scope"], mangle = compiler["global-mangling"], unmangle = compiler["global-unmangling"], compile1 = compiler.compile1, ["string-stream"] = parser["string-stream"], granulate = parser.granulate, loadCode = specials["load-code"], make_searcher = specials["make-searcher"], makeSearcher = specials["make-searcher"], searchModule = specials["search-module"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], macroLoaded = specials["macro-loaded"], compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], stringStream = parser["string-stream"], runtimeVersion = utils["runtime-version"]} + local mod = {["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-path"] = utils["macro-path"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["multi-sym?"] = utils["multi-sym?"], ["runtime-version"] = utils["runtime-version"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, runtimeVersion = utils["runtime-version"], scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, syntax = syntax, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = utils.version, view = view} mod.install = function(_3fopts) table.insert((package.searchers or package.loaders), specials["make-searcher"](_3fopts)) return mod @@ -5405,18 +5316,18 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) utils["fennel-module"] = mod do local module_name = "fennel.macros" - local _ - local function _741_() + local _ = nil + local function _713_() return mod end - package.preload[module_name] = _741_ + package.preload[module_name] = _713_ _ = nil - local env + local env = nil do - local _742_ = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) - do end (_742_)["utils"] = utils - _742_["fennel"] = mod - env = _742_ + local _714_0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) + _714_0["utils"] = utils + _714_0["fennel"] = mod + env = _714_0 end local built_ins = eval([===[;; These macros are awkward because their definition cannot rely on the any ;; built-in macros, only special forms. (no when, no icollect, etc) @@ -5567,8 +5478,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (into iter) (extract-into iter-tbl)] `(let [tbl# ,into] (each ,iter - (match ,kv-expr - (k# v#) (tset tbl# k# v#))) + (let [(k# v#) ,kv-expr] + (if (and (not= k# nil) (not= v# nil)) + (tset tbl# k# v#)))) tbl#))) (fn seq-collect [how iter-tbl value-expr ...] @@ -5829,8 +5741,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) :macro macro* :macrodebug macrodebug* :import-macros import-macros*} - ]===], {env = env, scope = compiler.scopes.compiler, allowedGlobals = false, useMetadata = true, filename = "src/fennel/macros.fnl", moduleName = module_name}) - local _0 + ]===], {env = env, filename = "src/fennel/macros.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) + local _0 = nil for k, v in pairs(built_ins) do compiler.scopes.global.macros[k] = v end @@ -5839,36 +5751,34 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) ;; This is separated out so we can use the "core" macros during the ;; implementation of pattern matching. - (fn without-multival [opts] - (if opts.multival? - (let [copy {}] - (each [k v (pairs opts)] - (tset copy k v)) - (tset copy :multival? nil) - copy) - opts)) + (fn copy [t] (collect [k v (pairs t)] k v)) - (fn match-values [vals pattern unifications match-pattern opts] + (fn with [opts k] + (doto (copy opts) (tset k true))) + + (fn without [opts k] + (doto (copy opts) (tset k nil))) + + (fn case-values [vals pattern unifications case-pattern opts] (let [condition `(and) bindings []] (each [i pat (ipairs pattern)] - (let [(subcondition subbindings) (match-pattern [(. vals i)] pat - unifications (without-multival opts))] + (let [(subcondition subbindings) (case-pattern [(. vals i)] pat + unifications (without opts :multival?))] (table.insert condition subcondition) - (each [_ b (ipairs subbindings)] - (table.insert bindings b)))) + (icollect [_ b (ipairs subbindings) &into bindings] b))) (values condition bindings))) - (fn match-table [val pattern unifications match-pattern opts] + (fn case-table [val pattern unifications case-pattern opts] (let [condition `(and (= (_G.type ,val) :table)) bindings []] (each [k pat (pairs pattern)] (if (= pat `&) (let [rest-pat (. pattern (+ k 1)) rest-val `(select ,k ((or table.unpack _G.unpack) ,val)) - subcondition (match-table `(pick-values 1 ,rest-val) - rest-pat unifications match-pattern - (without-multival opts))] + subcondition (case-table `(pick-values 1 ,rest-val) + rest-pat unifications case-pattern + (without opts :multival?))] (if (not (sym? rest-pat)) (table.insert condition subcondition)) (assert (= nil (. pattern (+ k 2))) @@ -5889,18 +5799,17 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (or (not= :number (type k)) (and (not= `&as (. pattern (- k 1))) (not= `& (. pattern (- k 1))))) (let [subval `(. ,val ,k) - (subcondition subbindings) (match-pattern [subval] pat + (subcondition subbindings) (case-pattern [subval] pat unifications - (without-multival opts))] + (without opts :multival?))] (table.insert condition subcondition) - (each [_ b (ipairs subbindings)] - (table.insert bindings b))))) + (icollect [_ b (ipairs subbindings) &into bindings] b)))) (values condition bindings))) - (fn match-guard [vals condition guards unifications match-pattern opts] + (fn case-guard [vals condition guards unifications case-pattern opts] (if (= 0 (length guards)) - (match-pattern vals condition unifications opts) - (let [(pcondition bindings) (match-pattern vals condition unifications opts) + (case-pattern vals condition unifications opts) + (let [(pcondition bindings) (case-pattern vals condition unifications opts) condition `(and ,(unpack guards))] (values `(and ,pcondition (let ,bindings @@ -5911,8 +5820,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (if (list? pattern) (let [result {}] (each [_ child-pattern (ipairs pattern)] - (each [name symbol (pairs (symbols-in-pattern child-pattern))] - (tset result name symbol))) + (collect [name symbol (pairs (symbols-in-pattern child-pattern)) &into result] + name symbol)) result) (sym? pattern) (if (and (not= pattern `or) @@ -5924,14 +5833,14 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (= (type pattern) :table) (let [result {}] (each [key-pattern value-pattern (pairs pattern)] - (each [name symbol (pairs (symbols-in-pattern key-pattern))] - (tset result name symbol)) - (each [name symbol (pairs (symbols-in-pattern value-pattern))] - (tset result name symbol))) + (collect [name symbol (pairs (symbols-in-pattern key-pattern)) &into result] + name symbol) + (collect [name symbol (pairs (symbols-in-pattern value-pattern)) &into result] + name symbol)) result) {})) - (fn symbols-in-every-pattern [pattern-list unification?] + (fn symbols-in-every-pattern [pattern-list infer-unification?] "gives a list of symbols that are present in every pattern in the list" (let [?symbols (accumulate [?symbols nil _ pattern (ipairs pattern-list)] @@ -5944,18 +5853,18 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) ?symbols) in-pattern)))] (icollect [_ symbol (pairs (or ?symbols {}))] - (if (not (and unification? (in-scope? symbol))) + (if (not (and infer-unification? + (in-scope? symbol))) symbol)))) - (fn match-or [vals pattern guards unifications match-pattern opts] - ;; if guards is present, this is a (where (or)) shape - (let [bindings (symbols-in-every-pattern [(unpack pattern 2)] opts.unification?)] + (fn case-or [vals pattern guards unifications case-pattern opts] + (let [pattern [(unpack pattern 2)] + bindings (symbols-in-every-pattern pattern opts.infer-unification?)] ;; TODO opts.infer-unification instead of opts.unification? (if (= 0 (length bindings)) ;; no bindings special case generates simple code (let [condition - (fcollect [i 2 (length pattern) &into `(or)] - (let [subpattern (. pattern i) - (subcondition subbindings) (match-pattern vals subpattern unifications opts)] + (icollect [i subpattern (ipairs pattern) &into `(or)] + (let [(subcondition subbindings) (case-pattern vals subpattern unifications opts)] subcondition))] (values (if (= 0 (length guards)) @@ -5964,19 +5873,19 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) [])) ;; case with bindings is handled specially, and returns three values instead of two (let [matched? (gensym :matched?) - bindings-two (icollect [_ binding (ipairs bindings)] - (gensym (tostring binding))) - the-actual-body `(if)] - (for [i 2 (length pattern)] - (let [subpattern (. pattern i) - (subcondition subbindings) (match-guard vals subpattern guards {} match-pattern opts)] - (table.insert the-actual-body subcondition) - (table.insert the-actual-body `(let ,subbindings (values true ,(unpack bindings)))))) + bindings-mangled (icollect [_ binding (ipairs bindings)] + (gensym (tostring binding))) + pre-bindings `(if)] + (each [i subpattern (ipairs pattern)] + (let [(subcondition subbindings) (case-guard vals subpattern guards {} case-pattern opts)] + (table.insert pre-bindings subcondition) + (table.insert pre-bindings `(let ,subbindings + (values true ,(unpack bindings)))))) (values matched? - [`(,(unpack bindings)) `(values ,(unpack bindings-two))] - [`(,matched? ,(unpack bindings-two)) the-actual-body]))))) + [`(,(unpack bindings)) `(values ,(unpack bindings-mangled))] + [`(,matched? ,(unpack bindings-mangled)) pre-bindings]))))) - (fn match-pattern [vals pattern unifications opts top-level?] + (fn case-pattern [vals pattern unifications opts top-level?] "Take the AST of values and a single pattern and returns a condition to determine if it matches as well as a list of bindings to introduce for the duration of the body if it does match." @@ -5987,17 +5896,27 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) ;; a "bindings", which bind all of the symbols used in a pattern ;; an optional "pre-bindings", which is a list of bindings that happen ;; before the condition and bindings are evaluated. These should only - ;; come from a (match-or). In this case there should be no recursion: - ;; the call stack should be match-condition > match-pattern > match-or + ;; come from a (case-or). In this case there should be no recursion: + ;; the call stack should be case-condition > case-pattern > case-or + ;; + ;; Here are the expected flags in the opts table: + ;; :infer-unification? boolean - if the pattern should guess when to unify (ie, match -> true, case -> false) + ;; :multival? boolean - if the pattern can contain multivals (in order to disallow patterns like [(1 2)]) + ;; :in-where? boolean - if the pattern is surrounded by (where) (where opts into more pattern features) + ;; :legacy-guard-allowed? boolean - if the pattern should allow `(a ? b) patterns ;; we have to assume we're matching against multiple values here until we ;; know we're either in a multi-valued clause (in which case we know the # ;; of vals) or we're not, in which case we only care about the first one. (let [[val] vals] - (if (or (and (sym? pattern) ; unification with outer locals (or nil) - (not= "_" (tostring pattern)) ; never unify _ - (or (and opts.unification? (in-scope? pattern)) (= :nil (tostring pattern)))) - (and (multi-sym? pattern) opts.unification? (in-scope? (. (multi-sym? pattern) 1)))) + (if (and (sym? pattern) + (or (= pattern `nil) + (and opts.infer-unification? + (in-scope? pattern) + (not= pattern `_)) + (and opts.infer-unification? + (multi-sym? pattern) + (in-scope? (. (multi-sym? pattern) 1))))) (values `(= ,val ,pattern) []) ;; unify a local we've seen already (and (sym? pattern) (. unifications (tostring pattern))) @@ -6008,109 +5927,140 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (if (not wildcard?) (tset unifications (tostring pattern) val)) (values (if (or wildcard? (string.find (tostring pattern) "^?")) true `(not= ,(sym :nil) ,val)) [pattern val])) - + ;; opt-in unify with (=) + (and (list? pattern) + (= (. pattern 1) `=) + (sym? (. pattern 2))) + (let [bind (. pattern 2)] + (assert-compile (= 2 (length pattern)) "(=) should take only one argument" pattern) + (assert-compile (not opts.infer-unification?) "(=) cannot be used inside of match" pattern) + (assert-compile opts.in-where? "(=) must be used in (where) patterns" pattern) + (assert-compile (and (sym? bind) (not= bind `nil) "= has to bind to a symbol" bind)) + (values `(= ,val ,bind) [])) ;; where-or clause (and (list? pattern) (= (. pattern 1) `where) (list? (. pattern 2)) (= (. pattern 2 1) `or)) (do (assert-compile top-level? "can't nest (where) pattern" pattern) - (match-or vals (. pattern 2) [(unpack pattern 3)] unifications match-pattern opts)) - ;; or clause - (and (list? pattern) (= (. pattern 1) `or)) - (do - (assert-compile top-level? "can't nest (or) pattern" pattern) - (match-or vals pattern [] unifications match-pattern opts)) + (case-or vals (. pattern 2) [(unpack pattern 3)] unifications case-pattern (with opts :in-where?))) ;; where clause (and (list? pattern) (= (. pattern 1) `where)) (do (assert-compile top-level? "can't nest (where) pattern" pattern) - (match-guard vals (. pattern 2) [(unpack pattern 3)] unifications match-pattern opts)) + (case-guard vals (. pattern 2) [(unpack pattern 3)] unifications case-pattern (with opts :in-where?))) + ;; or clause (not allowed on its own) + (and (list? pattern) (= (. pattern 1) `or)) + (do + (assert-compile top-level? "can't nest (or) pattern" pattern) + ;; This assertion can be removed to make patterns more permissive + (assert-compile false "(or) must be used in (where) patterns" pattern) + (case-or vals pattern [] unifications case-pattern opts)) ;; guard clause (and (list? pattern) (= (. pattern 2) `?)) - (match-guard vals (. pattern 1) [(unpack pattern 3)] unifications match-pattern opts) + (do + (assert-compile opts.legacy-guard-allowed? "legacy guard clause not supported in case" pattern) + (case-guard vals (. pattern 1) [(unpack pattern 3)] unifications case-pattern opts)) ;; multi-valued patterns (represented as lists) (list? pattern) (do (assert-compile opts.multival? "can't nest multi-value destructuring" pattern) - (match-values vals pattern unifications match-pattern opts)) + (case-values vals pattern unifications case-pattern opts)) ;; table patterns (= (type pattern) :table) - (match-table val pattern unifications match-pattern opts) + (case-table val pattern unifications case-pattern opts) ;; literal value (values `(= ,val ,pattern) [])))) - (fn match-condition [vals clauses unification?] + (fn add-pre-bindings [out pre-bindings] + "Decide when to switch from the current `if` AST to a new one" + (if pre-bindings + ;; `out` no longer needs to grow. + ;; Instead, a new tail `if` AST is introduced, which is where the rest of + ;; the clauses will get appended. This way, all future clauses have the + ;; pre-bindings in scope. + (let [tail `(if)] + (table.insert out true) + (table.insert out `(let ,pre-bindings ,tail)) + tail) + ;; otherwise, keep growing the current `if` AST. + out)) + + (fn case-condition [vals clauses match?] "Construct the actual `if` AST for the given match values and clauses." - (when (not= 0 (% (length clauses) 2)) ; treat odd final clause as default - (table.insert clauses (length clauses) (sym "_"))) - (let [out `(if)] - (var tail out) - (for [i 1 (length clauses) 2] + ;; root is the original `if` AST. + ;; out is the `if` AST that is currently being grown. + (let [root `(if)] + (faccumulate [out root + i 1 (length clauses) 2] (let [pattern (. clauses i) body (. clauses (+ i 1)) - (condition bindings pre-bindings) (match-pattern vals pattern {} {:multival? true : unification?} true)] - (when pre-bindings - (if (. tail 2) - (let [newtail `()] - (table.insert tail newtail) - (set tail newtail))) - (let [newtail `(if)] - (tset tail 1 `let) - (tset tail 2 pre-bindings) - (tset tail 3 newtail) - (set tail newtail))) - (table.insert tail condition) - (table.insert tail `(let ,bindings - ,body)))) - out)) + (condition bindings pre-bindings) (case-pattern vals pattern {} + {:multival? true + :infer-unification? match? + :legacy-guard-allowed? match?} + true) + out (add-pre-bindings out pre-bindings)] + ;; grow the `if` AST by one extra condition + (table.insert out condition) + (table.insert out `(let ,bindings + ,body)) + out)) + root)) - (fn count-match-multival [pattern] + (fn count-case-multival [pattern] + "Identify the amount of multival values that a pattern requires." (if (and (list? pattern) (= (. pattern 2) `?)) - (count-match-multival (. pattern 1)) + (count-case-multival (. pattern 1)) (and (list? pattern) (= (. pattern 1) `where)) - (count-match-multival (. pattern 2)) + (count-case-multival (. pattern 2)) (and (list? pattern) (= (. pattern 1) `or)) (accumulate [longest 0 _ child-pattern (ipairs pattern)] - (math.max longest (count-match-multival child-pattern))) + (math.max longest (count-case-multival child-pattern))) (list? pattern) (length pattern) 1)) - (fn match-val-syms [clauses] - "What is the length of the largest multi-valued clause? return a list of that many gensyms." + (fn case-val-syms [clauses] + "What is the length of the largest multi-valued clause? return a list of that + many gensyms." (let [patterns (fcollect [i 1 (length clauses) 2] (. clauses i)) sym-count (accumulate [longest 0 _ pattern (ipairs patterns)] - (math.max longest (count-match-multival pattern)))] + (math.max longest (count-case-multival pattern)))] (fcollect [i 1 sym-count &into (list)] (gensym)))) - (fn match* [val ...] + (fn case-impl [match? val ...] + "The shared implementation of case and match." + (assert (not= val nil) "missing subject") + (assert (= 0 (math.fmod (select :# ...) 2)) + "expected even number of pattern/body pairs") + (assert (not= 0 (select :# ...)) + "expected at least one pattern/body pair") + (let [clauses [...] + vals (case-val-syms clauses)] + ;; protect against multiple evaluation of the value, bind against as + ;; many values as we ever match against in the clauses. + (list `let [vals val] (case-condition vals clauses match?)))) + + (fn case* [val ...] "Perform pattern matching on val. See reference for details. Syntax: - (match data-expression + (case data-expression pattern body (where pattern guards*) body (or pattern patterns*) body (where (or pattern patterns*) guards*) body ;; legacy: (pattern ? guards*) body)" - (assert (not= val nil) "missing subject") - (assert (= 0 (math.fmod (select :# ...) 2)) - "expected even number of pattern/body pairs") - (assert (not= 0 (select :# ...)) - "expected at least one pattern/body pair") - (let [clauses [...] - vals (match-val-syms clauses)] - ;; protect against multiple evaluation of the value, bind against as - ;; many values as we ever match against in the clauses. - (list `let [vals val] (match-condition vals clauses true)))) + (case-impl false val ...)) - (fn matchless* [val ...] - "Perform pattern matching on val, without unifying on variables in local scope. See reference for details. + (fn match* [val ...] + "Perform pattern matching on val, automatically unifying on variables in + local scope. See reference for details. Syntax: @@ -6121,29 +6071,45 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (where (or pattern patterns*) guards*) body ;; legacy: (pattern ? guards*) body)" - (assert (not= val nil) "missing subject") - (assert (= 0 (math.fmod (select :# ...) 2)) - "expected even number of pattern/body pairs") - (assert (not= 0 (select :# ...)) - "expected at least one pattern/body pair") - (let [clauses [...] - vals (match-val-syms clauses)] - ;; protect against multiple evaluation of the value, bind against as - ;; many values as we ever match against in the clauses. - (list `let [vals val] (match-condition vals clauses false)))) + (case-impl true val ...)) - (fn match-try-step [expr else pattern body ...] + (fn case-try-step [how expr else pattern body ...] (if (= nil pattern body) expr ;; unlike regular match, we can't know how many values the value ;; might evaluate to, so we have to capture them all in ... via IIFE ;; to avoid double-evaluation. `((fn [...] - (match ... - ,pattern ,(match-try-step body else ...) + (,how ... + ,pattern ,(case-try-step how body else ...) ,(unpack else))) ,expr))) + (fn case-try-impl [how expr pattern body ...] + (let [clauses [pattern body ...] + last (. clauses (length clauses)) + catch (if (= `catch (and (= :table (type last)) (. last 1))) + (let [[_ & e] (table.remove clauses)] e) ; remove `catch sym + [`_# `...])] + (assert (= 0 (math.fmod (length clauses) 2)) + "expected every pattern to have a body") + (assert (= 0 (math.fmod (length catch) 2)) + "expected every catch pattern to have a body") + (case-try-step how expr catch (unpack clauses)))) + + (fn case-try* [expr pattern body ...] + "Perform chained pattern matching for a sequence of steps which might fail. + + The values from the initial expression are matched against the first pattern. + If they match, the first body is evaluated and its values are matched against + the second pattern, etc. + + If there is a (catch pat1 body1 pat2 body2 ...) form at the end, any mismatch + from the steps will be tried against these patterns in sequence as a fallback + just like a normal match. If there is no catch, the mismatched values will be + returned as the value of the entire expression." + (case-try-impl `case expr pattern body ...)) + (fn match-try* [expr pattern body ...] "Perform chained pattern matching for a sequence of steps which might fail. @@ -6155,21 +6121,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) from the steps will be tried against these patterns in sequence as a fallback just like a normal match. If there is no catch, the mismatched values will be returned as the value of the entire expression." - (let [clauses [pattern body ...] - last (. clauses (length clauses)) - catch (if (= `catch (and (= :table (type last)) (. last 1))) - (let [[_ & e] (table.remove clauses)] e) ; remove `catch sym - [`_# `...])] - (assert (= 0 (math.fmod (length clauses) 2)) - "expected every pattern to have a body") - (assert (= 0 (math.fmod (length catch) 2)) - "expected every catch pattern to have a body") - (match-try-step expr catch (unpack clauses)))) + (case-try-impl `match expr pattern body ...)) - {:match match* - :matchless matchless* + {:case case* + :case-try case-try* + :match match* :match-try match-try*} - ]===], {env = env, scope = compiler.scopes.compiler, allowedGlobals = false, useMetadata = true, filename = "src/fennel/match.fnl", moduleName = module_name}) + ]===], {allowedGlobals = false, env = env, filename = "src/fennel/match.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) for k, v in pairs(match_macros) do compiler.scopes.global.macros[k] = v end @@ -6179,46 +6137,44 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) end fennel = require("fennel") local unpack = (table.unpack or _G.unpack) -local help = "\nUsage: fennel [FLAG] [FILE]\n\nRun fennel, a lisp programming language for the Lua runtime.\n\n --repl : Command to launch an interactive repl session\n --compile FILES (-c) : Command to AOT compile files, writing Lua to stdout\n --eval SOURCE (-e) : Command to evaluate source code and print the result\n\n --no-searcher : Skip installing package.searchers entry\n --indent VAL : Indent compiler output with VAL\n --add-package-path PATH : Add PATH to package.path for finding Lua modules\n --add-fennel-path PATH : Add PATH to fennel.path for finding Fennel modules\n --add-macro-path PATH : Add PATH to fennel.macro-path for macro modules\n --globals G1[,G2...] : Allow these globals in addition to standard ones\n --globals-only G1[,G2] : Same as above, but exclude standard ones\n --require-as-include : Inline required modules in the output\n --skip-include M1[,M2] : Omit certain modules from output when included\n --use-bit-lib : Use LuaJITs bit library instead of operators\n --metadata : Enable function metadata, even in compiled output\n --no-metadata : Disable function metadata, even in REPL\n --correlate : Make Lua output line numbers match Fennel input\n --load FILE (-l) : Load the specified FILE before executing the command\n --lua LUA_EXE : Run in a child process with LUA_EXE\n --no-fennelrc : Skip loading ~/.fennelrc when launching repl\n --raw-errors : Disable friendly compile error reporting\n --plugin FILE : Activate the compiler plugin in FILE\n --compile-binary FILE\n OUT LUA_LIB LUA_DIR : Compile FILE to standalone binary OUT\n --compile-binary --help : Display further help for compiling binaries\n --no-compiler-sandbox : Do not limit compiler environment to minimal sandbox\n\n --help (-h) : Display this text\n --version (-v) : Show version\n\nGlobals are not checked when doing AOT (ahead-of-time) compilation unless\nthe --globals-only or --globals flag is provided. Use --globals \"*\" to disable\nstrict globals checking in other contexts.\n\nMetadata is typically considered a development feature and is not recommended\nfor production. It is used for docstrings and enabled by default in the REPL.\n\nWhen not given a command, runs the file given as the first argument.\nWhen given neither command nor file, launches a repl.\n\nIf ~/.fennelrc exists, it will be loaded before launching a repl." +local help = "\nUsage: fennel [FLAG] [FILE]\n\nRun fennel, a lisp programming language for the Lua runtime.\n\n --repl : Command to launch an interactive repl session\n --compile FILES (-c) : Command to AOT compile files, writing Lua to stdout\n --eval SOURCE (-e) : Command to evaluate source code and print the result\n\n --no-searcher : Skip installing package.searchers entry\n --indent VAL : Indent compiler output with VAL\n --add-package-path PATH : Add PATH to package.path for finding Lua modules\n --add-fennel-path PATH : Add PATH to fennel.path for finding Fennel modules\n --add-macro-path PATH : Add PATH to fennel.macro-path for macro modules\n --globals G1[,G2...] : Allow these globals in addition to standard ones\n --globals-only G1[,G2] : Same as above, but exclude standard ones\n --require-as-include : Inline required modules in the output\n --skip-include M1[,M2] : Omit certain modules from output when included\n --use-bit-lib : Use LuaJITs bit library instead of operators\n --metadata : Enable function metadata, even in compiled output\n --no-metadata : Disable function metadata, even in REPL\n --correlate : Make Lua output line numbers match Fennel input\n --load FILE (-l) : Load the specified FILE before executing the command\n --lua LUA_EXE : Run in a child process with LUA_EXE\n --no-fennelrc : Skip loading ~/.fennelrc when launching repl\n --raw-errors : Disable friendly compile error reporting\n --plugin FILE : Activate the compiler plugin in FILE\n --compile-binary FILE\n OUT LUA_LIB LUA_DIR : Compile FILE to standalone binary OUT\n --compile-binary --help : Display further help for compiling binaries\n --no-compiler-sandbox : Do not limit compiler environment to minimal sandbox\n\n --help (-h) : Display this text\n --version (-v) : Show version\n\nGlobals are not checked when doing AOT (ahead-of-time) compilation unless\nthe --globals-only or --globals flag is provided. Use --globals \"*\" to disable\nstrict globals checking in other contexts.\n\nMetadata is typically considered a development feature and is not recommended\nfor production. It is used for docstrings and enabled by default in the REPL.\n\nWhen not given a command, runs the file given as the first argument.\nWhen given neither command nor file, launches a repl.\n\nUse the NO_COLOR environment variable to disable escape codes in error messages.\n\nIf ~/.fennelrc exists, it will be loaded before launching a repl." local options = {plugins = {}} local function pack(...) - local _743_ = {...} - _743_["n"] = select("#", ...) - return _743_ + local _715_0 = {...} + _715_0["n"] = select("#", ...) + return _715_0 end local function dosafely(f, ...) local args = {...} - local result - local function _744_() + local result = nil + local function _716_() return f(unpack(args)) end - result = pack(xpcall(_744_, fennel.traceback)) + result = pack(xpcall(_716_, fennel.traceback)) if not result[1] then do end (io.stderr):write((result[2] .. "\n")) os.exit(1) - else end return unpack(result, 2, result.n) end -local function allow_globals(global_names, globals) - if (global_names == "*") then +local function allow_globals(names, actual_globals) + if (names == "*") then options.allowedGlobals = false return nil else do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for g in global_names:gmatch("([^,]+),?") do - local val_16_auto = g - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for g in names:gmatch("([^,]+),?") do + local val_19_ = g + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - options.allowedGlobals = tbl_14_auto + options.allowedGlobals = tbl_17_ end - for global_name in pairs(globals) do + for global_name in pairs(actual_globals) do table.insert(options.allowedGlobals, global_name) end return nil @@ -6232,123 +6188,118 @@ end local function handle_lua(i) table.remove(arg, i) local tgt_lua = table.remove(arg, i) - local cmd = {string.format("%s %s", tgt_lua, arg[0])} + local cmd = {string.format("%s %s", tgt_lua, (arg[0] or "fennel"))} for i0 = 1, #arg do table.insert(cmd, string.format("%q", arg[i0])) end local ok = os.execute(table.concat(cmd, " ")) - local _748_ + local _720_ if ok then - _748_ = 0 + _720_ = 0 else - _748_ = 1 + _720_ = 1 end - return os.exit(_748_, true) + return os.exit(_720_, true) end assert(arg, "Using the launcher from non-CLI context; use fennel.lua instead.") for i = #arg, 1, -1 do - local _750_ = arg[i] - if (_750_ == "--lua") then + local _722_0 = arg[i] + if (_722_0 == "--lua") then handle_lua(i) - else end end do - local commands = {["--repl"] = true, ["--compile"] = true, ["-c"] = true, ["--compile-binary"] = true, ["--eval"] = true, ["-e"] = true, ["-v"] = true, ["--version"] = true, ["--help"] = true, ["-h"] = true, ["-"] = true} + local commands = {["-"] = true, ["--compile"] = true, ["--compile-binary"] = true, ["--eval"] = true, ["--help"] = true, ["--repl"] = true, ["--version"] = true, ["-c"] = true, ["-e"] = true, ["-h"] = true, ["-v"] = true} local i = 1 while (arg[i] and not options["ignore-options"]) do - local _752_ = arg[i] - if (_752_ == "--no-searcher") then + local _724_0 = arg[i] + if (_724_0 == "--no-searcher") then options["no-searcher"] = true table.remove(arg, i) - elseif (_752_ == "--indent") then + elseif (_724_0 == "--indent") then options.indent = table.remove(arg, (i + 1)) if (options.indent == "false") then options.indent = false - else end table.remove(arg, i) - elseif (_752_ == "--add-package-path") then + elseif (_724_0 == "--add-package-path") then local entry = table.remove(arg, (i + 1)) package.path = (entry .. ";" .. package.path) table.remove(arg, i) - elseif (_752_ == "--add-fennel-path") then + elseif (_724_0 == "--add-fennel-path") then local entry = table.remove(arg, (i + 1)) fennel.path = (entry .. ";" .. fennel.path) table.remove(arg, i) - elseif (_752_ == "--add-macro-path") then + elseif (_724_0 == "--add-macro-path") then local entry = table.remove(arg, (i + 1)) fennel["macro-path"] = (entry .. ";" .. fennel["macro-path"]) table.remove(arg, i) - elseif (_752_ == "--load") then + elseif (_724_0 == "--load") then handle_load(i) - elseif (_752_ == "-l") then + elseif (_724_0 == "-l") then handle_load(i) - elseif (_752_ == "--no-fennelrc") then + elseif (_724_0 == "--no-fennelrc") then options.fennelrc = false table.remove(arg, i) - elseif (_752_ == "--correlate") then + elseif (_724_0 == "--correlate") then options.correlate = true table.remove(arg, i) - elseif (_752_ == "--check-unused-locals") then + elseif (_724_0 == "--check-unused-locals") then options.checkUnusedLocals = true table.remove(arg, i) - elseif (_752_ == "--globals") then + elseif (_724_0 == "--globals") then allow_globals(table.remove(arg, (i + 1)), _G) table.remove(arg, i) - elseif (_752_ == "--globals-only") then + elseif (_724_0 == "--globals-only") then allow_globals(table.remove(arg, (i + 1)), {}) table.remove(arg, i) - elseif (_752_ == "--require-as-include") then + elseif (_724_0 == "--require-as-include") then options.requireAsInclude = true table.remove(arg, i) - elseif (_752_ == "--skip-include") then + elseif (_724_0 == "--skip-include") then local skip_names = table.remove(arg, (i + 1)) - local skip + local skip = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for m in skip_names:gmatch("([^,]+)") do - local val_16_auto = m - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = m + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - skip = tbl_14_auto + skip = tbl_17_ end options.skipInclude = skip table.remove(arg, i) - elseif (_752_ == "--use-bit-lib") then + elseif (_724_0 == "--use-bit-lib") then options.useBitLib = true table.remove(arg, i) - elseif (_752_ == "--metadata") then + elseif (_724_0 == "--metadata") then options.useMetadata = true table.remove(arg, i) - elseif (_752_ == "--no-metadata") then + elseif (_724_0 == "--no-metadata") then options.useMetadata = false table.remove(arg, i) - elseif (_752_ == "--no-compiler-sandbox") then + elseif (_724_0 == "--no-compiler-sandbox") then options["compiler-env"] = _G table.remove(arg, i) - elseif (_752_ == "--raw-errors") then + elseif (_724_0 == "--raw-errors") then options.unfriendly = true table.remove(arg, i) - elseif (_752_ == "--plugin") then - local opts = {env = "_COMPILER", useMetadata = true, ["compiler-env"] = _G} + elseif (_724_0 == "--plugin") then + local opts = {["compiler-env"] = _G, env = "_COMPILER", useMetadata = true} local plugin = fennel.dofile(table.remove(arg, (i + 1)), opts) table.insert(options.plugins, 1, plugin) table.remove(arg, i) - elseif true then - local _ = _752_ + else + local _ = _724_0 if not commands[arg[i]] then options["ignore-options"] = true i = (i + 1) - else end i = (i + 1) - else end end end @@ -6358,7 +6309,6 @@ if not options["no-searcher"] then searcher_opts[k] = v end table.insert((package.loaders or package.searchers), fennel["make-searcher"](searcher_opts)) -else end local function load_initfile() local home = (os.getenv("HOME") or "/") @@ -6366,7 +6316,7 @@ local function load_initfile() local xdg_initfile = (xdg_config_home .. "/fennel/fennelrc") local home_initfile = (home .. "/.fennelrc") local init = io.open(xdg_initfile, "rb") - local init_filename + local init_filename = nil if init then init_filename = xdg_initfile else @@ -6376,119 +6326,113 @@ local function load_initfile() if init0 then init0:close() return dosafely(fennel.dofile, init_filename, options, options, fennel) - else - return nil end end local function repl() local readline_3f = (("dumb" ~= os.getenv("TERM")) and pcall(require, "readline")) searcher_opts.useMetadata = (false ~= options.useMetadata) if (false ~= options.fennelrc) then - load_initfile() - else + options["fennelrc"] = load_initfile end print(("Welcome to " .. fennel["runtime-version"]() .. "!")) print("Use ,help to see available commands.") if (not readline_3f and ("dumb" ~= os.getenv("TERM"))) then print("Try installing readline via luarocks for a better repl experience.") - else end return fennel.repl(options) end local function eval(form) - local _762_ + local _734_ if (form == "-") then - _762_ = (io.stdin):read("*a") + _734_ = (io.stdin):read("*a") else - _762_ = form + _734_ = form end - return print(dosafely(fennel.eval, _762_, options)) + return print(dosafely(fennel.eval, _734_, options)) end local function compile(files) for _, filename in ipairs(files) do options.filename = filename - local f + local f = nil if (filename == "-") then f = io.stdin else f = assert(io.open(filename, "rb")) end do - local _765_, _766_ = nil, nil - local function _767_() + local _737_0, _738_0 = nil, nil + local function _739_() return fennel["compile-string"](f:read("*a"), options) end - _765_, _766_ = xpcall(_767_, fennel.traceback) - if ((_765_ == true) and (nil ~= _766_)) then - local val = _766_ + _737_0, _738_0 = xpcall(_739_, fennel.traceback) + if ((_737_0 == true) and (nil ~= _738_0)) then + local val = _738_0 print(val) - elseif (true and (nil ~= _766_)) then - local _0 = _765_ - local msg = _766_ + elseif (true and (nil ~= _738_0)) then + local _0 = _737_0 + local msg = _738_0 do end (io.stderr):write((msg .. "\n")) os.exit(1) - else end end f:close() end return nil end -local _769_ = arg -local function _770_(...) +local _741_0 = arg +local function _742_(...) return (0 == #arg) end -if ((_G.type(_769_) == "table") and _770_(...)) then +if ((_G.type(_741_0) == "table") and _742_(...)) then return repl() -elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "--repl")) then +elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "--repl")) then return repl() -elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "--compile")) then - local files = {select(2, (table.unpack or _G.unpack)(_769_))} +elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "--compile")) then + local files = {select(2, (table.unpack or _G.unpack)(_741_0))} return compile(files) -elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "-c")) then - local files = {select(2, (table.unpack or _G.unpack)(_769_))} +elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "-c")) then + local files = {select(2, (table.unpack or _G.unpack)(_741_0))} return compile(files) -elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "--compile-binary") and (nil ~= (_769_)[2]) and (nil ~= (_769_)[3]) and (nil ~= (_769_)[4]) and (nil ~= (_769_)[5])) then - local filename = (_769_)[2] - local out = (_769_)[3] - local static_lua = (_769_)[4] - local lua_include_dir = (_769_)[5] - local args = {select(6, (table.unpack or _G.unpack)(_769_))} +elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "--compile-binary") and (nil ~= _741_0[2]) and (nil ~= _741_0[3]) and (nil ~= _741_0[4]) and (nil ~= _741_0[5])) then + local filename = _741_0[2] + local out = _741_0[3] + local static_lua = _741_0[4] + local lua_include_dir = _741_0[5] + local args = {select(6, (table.unpack or _G.unpack)(_741_0))} local bin = require("fennel.binary") options.filename = filename options.requireAsInclude = true return bin.compile(filename, out, static_lua, lua_include_dir, options, args) -elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "--compile-binary")) then - return print((require("fennel.binary")).help) -elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "--eval") and (nil ~= (_769_)[2])) then - local form = (_769_)[2] +elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "--compile-binary")) then + local cmd = (arg[0] or "fennel") + return print((require("fennel.binary").help):format(cmd, cmd, cmd)) +elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "--eval") and (nil ~= _741_0[2])) then + local form = _741_0[2] return eval(form) -elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "-e") and (nil ~= (_769_)[2])) then - local form = (_769_)[2] +elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "-e") and (nil ~= _741_0[2])) then + local form = _741_0[2] return eval(form) else - local function _798_(...) - local a = (_769_)[1] + local function _770_(...) + local a = _741_0[1] return ((a == "-v") or (a == "--version")) end - if (((_G.type(_769_) == "table") and (nil ~= (_769_)[1])) and _798_(...)) then - local a = (_769_)[1] + if (((_G.type(_741_0) == "table") and (nil ~= _741_0[1])) and _770_(...)) then + local a = _741_0[1] return print(fennel["runtime-version"]()) - elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "--help")) then + elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "--help")) then return print(help) - elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "-h")) then + elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "-h")) then return print(help) - elseif ((_G.type(_769_) == "table") and ((_769_)[1] == "-")) then - local args = {select(2, (table.unpack or _G.unpack)(_769_))} + elseif ((_G.type(_741_0) == "table") and (_741_0[1] == "-")) then + local args = {select(2, (table.unpack or _G.unpack)(_741_0))} return dosafely(fennel.eval, (io.stdin):read("*a")) - elseif ((_G.type(_769_) == "table") and (nil ~= (_769_)[1])) then - local filename = (_769_)[1] - local args = {select(2, (table.unpack or _G.unpack)(_769_))} + elseif ((_G.type(_741_0) == "table") and (nil ~= _741_0[1])) then + local filename = _741_0[1] + local args = {select(2, (table.unpack or _G.unpack)(_741_0))} arg[-2] = arg[-1] arg[-1] = arg[0] arg[0] = table.remove(arg, 1) return dosafely(fennel.dofile, filename, options, unpack(args)) - else - return nil end end diff --git a/src/fennel-ls/compiler.fnl b/src/fennel-ls/compiler.fnl index c33f2cf..a422995 100644 --- a/src/fennel-ls/compiler.fnl +++ b/src/fennel-ls/compiler.fnl @@ -131,12 +131,12 @@ later by fennel-ls.language to answer requests from the client." (tset require-calls ast true))) (λ recoverable? [msg] - (or (msg:find "unknown identifier in strict mode") - (msg:find "expected closing delimiter") - (msg:find "expected body expression") - (msg:find "expected whitespace before opening delimiter") - (msg:find "malformed multisym") - (msg:find "expected at least one pattern/body pair"))) + (or (= 1 (msg:find "unknown identifier")) + (= 1 (msg:find "expected closing delimiter")) + (= 1 (msg:find "expected body expression")) + (= 1 (msg:find "expected whitespace before opening delimiter")) + (= 1 (msg:find "malformed multisym")) + (= 1 (msg:find "expected at least one pattern/body pair")))) (λ on-compile-error [_ msg ast call-me-to-reset-the-compiler] (let [range (or (message.ast->range ast file) @@ -175,7 +175,7 @@ later by fennel-ls.language to answer requests from the client." [macro-file? (= (: file.text :sub 1 24) ";; fennel-ls: macro-file") plugin {:name "fennel-ls" - :versions ["1.3.0"] + :versions ["1.3.1"] :symbol-to-expression reference : call :destructure define diff --git a/src/fennel.lua b/src/fennel.lua index fc889e9..ac75b59 100644 --- a/src/fennel.lua +++ b/src/fennel.lua @@ -6,14 +6,14 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local view = require("fennel.view") local unpack = (table.unpack or _G.unpack) local function default_read_chunk(parser_state) - local function _621_() + local function _591_() if (0 < parser_state["stack-size"]) then return ".." else return ">> " end end - io.write(_621_()) + io.write(_591_()) io.flush() local input = io.read() return (input and (input .. "\n")) @@ -23,41 +23,76 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) return io.write("\n") end local function default_on_error(errtype, err, lua_source) - local function _623_() - local _622_ = errtype - if (_622_ == "Lua Compile") then + local function _593_() + local _592_0 = errtype + if (_592_0 == "Lua Compile") then return ("Bad code generated - likely a bug with the compiler:\n" .. "--- Generated Lua Start ---\n" .. lua_source .. "--- Generated Lua End ---\n") - elseif (_622_ == "Runtime") then + elseif (_592_0 == "Runtime") then return (compiler.traceback(tostring(err), 4) .. "\n") - elseif true then - local _ = _622_ - return ("%s error: %s\n"):format(errtype, tostring(err)) else - return nil + local _ = _592_0 + return ("%s error: %s\n"):format(errtype, tostring(err)) end end - return io.write(_623_()) + return io.write(_593_()) end - local save_source = " ___replLocals___['%s'] = %s" local function splice_save_locals(env, lua_source, scope) - local spliced_source = {} - local bind = "local %s = ___replLocals___['%s']" - for line in lua_source:gmatch("([^\n]+)\n?") do - table.insert(spliced_source, line) - end - for name in pairs(env.___replLocals___) do - table.insert(spliced_source, 1, bind:format(name, name)) - end - if ((1 < #spliced_source) and (spliced_source[#spliced_source]):match("^ *return .*$")) then - for _, name in pairs(scope.manglings) do - if not scope.gensyms[name] then - table.insert(spliced_source, #spliced_source, save_source:format(name, name)) - else + local saves = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for name in pairs(env.___replLocals___) do + local val_19_ = ("local %s = ___replLocals___['%s']"):format(name, name) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - else + saves = tbl_17_ end - return table.concat(spliced_source, "\n") + local binds = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, name in pairs(scope.manglings) do + local val_19_ = nil + if not scope.gensyms[name] then + val_19_ = ("___replLocals___['%s'] = %s"):format(name, name) + else + val_19_ = nil + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + binds = tbl_17_ + end + local gap = nil + if lua_source:find("\n") then + gap = "\n" + else + gap = " " + end + local function _599_() + if next(saves) then + return (table.concat(saves, " ") .. gap) + else + return "" + end + end + local function _602_() + local _600_0, _601_0 = lua_source:match("^(.*)[\n ](return .*)$") + if ((nil ~= _600_0) and (nil ~= _601_0)) then + local body = _600_0 + local _return = _601_0 + return (body .. gap .. table.concat(binds, " ") .. gap .. _return) + else + local _ = _600_0 + return lua_source + end + end + return (_599_() .. _602_()) end local function completer(env, scope, text) local max_items = 2000 @@ -67,20 +102,20 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local stop_looking_3f = false local function add_partials(input, tbl, prefix) local scope_first_3f = ((tbl == env) or (tbl == env.___replLocals___)) - local tbl_14_auto = matches - local i_15_auto = #tbl_14_auto - local function _627_() + local tbl_17_ = matches + local i_18_ = #tbl_17_ + local function _604_() if scope_first_3f then return scope.manglings else return tbl end end - for k, is_mangled in utils.allpairs(_627_()) do + for k, is_mangled in utils.allpairs(_604_()) do if (max_items <= #matches) then break end - local val_16_auto + local val_19_ = nil do - local lookup_k + local lookup_k = nil if scope_first_3f then lookup_k = is_mangled else @@ -88,21 +123,20 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end if ((type(k) == "string") and (input == k:sub(0, #input)) and not seen[k] and ((":" ~= prefix:sub(-1)) or ("function" == type(tbl[lookup_k])))) then seen[k] = true - val_16_auto = (prefix .. k) + val_19_ = (prefix .. k) else - val_16_auto = nil + val_19_ = nil end end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_14_auto + return tbl_17_ end local function descend(input, tbl, prefix, add_matches, method_3f) - local splitter + local splitter = nil if method_3f then splitter = "^([^:]+):(.*)" else @@ -117,12 +151,10 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) else return add_matches(tail, tbl[raw_head], (prefix .. head)) end - else - return nil end end local function add_matches(input, tbl, prefix) - local prefix0 + local prefix0 = nil if prefix then prefix0 = (prefix .. ".") else @@ -147,35 +179,34 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) return input:match("^%s*,") end local function command_docs() - local _636_ + local _613_ do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for name, f in pairs(commands) do - local val_16_auto = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _636_ = tbl_14_auto + _613_ = tbl_17_ end - return table.concat(_636_, "\n") + return table.concat(_613_, "\n") end commands.help = function(_, _0, on_values) return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference")}) end do end (compiler.metadata):set(commands.help, "fnl/docstring", "Show this message.") local function reload(module_name, env, on_values, on_error) - local _638_, _639_ = pcall(specials["load-code"]("return require(...)", env), module_name) - if ((_638_ == true) and (nil ~= _639_)) then - local old = _639_ - local _ + local _615_0, _616_0 = pcall(specials["load-code"]("return require(...)", env), module_name) + if ((_615_0 == true) and (nil ~= _616_0)) then + local old = _616_0 + local _ = nil package.loaded[module_name] = nil _ = nil local ok, new = pcall(require, module_name) - local new0 + local new0 = nil if not ok then on_values({new}) new0 = old @@ -188,47 +219,44 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) old[k] = v end for k in pairs(old) do - if (nil == (new0)[k]) then + if (nil == new0[k]) then old[k] = nil - else end end package.loaded[module_name] = old - else end return on_values({"ok"}) - elseif ((_638_ == false) and (nil ~= _639_)) then - local msg = _639_ - if (specials["macro-loaded"])[module_name] then + elseif ((_615_0 == false) and (nil ~= _616_0)) then + local msg = _616_0 + if msg:match("loop or previous error loading module") then + package.loaded[module_name] = nil + return reload(module_name, env, on_values, on_error) + elseif specials["macro-loaded"][module_name] then specials["macro-loaded"][module_name] = nil return nil else - local function _644_() - local _643_ = msg:gsub("\n.*", "") - return _643_ + local function _621_() + local _620_0 = msg:gsub("\n.*", "") + return _620_0 end - return on_error("Runtime", _644_()) + return on_error("Runtime", _621_()) end - else - return nil end end local function run_command(read, on_error, f) - local _647_, _648_, _649_ = pcall(read) - if ((_647_ == true) and (_648_ == true) and (nil ~= _649_)) then - local val = _649_ + local _624_0, _625_0, _626_0 = pcall(read) + if ((_624_0 == true) and (_625_0 == true) and (nil ~= _626_0)) then + local val = _626_0 return f(val) - elseif (_647_ == false) then + elseif (_624_0 == false) then return on_error("Parse", "Couldn't parse input.") - else - return nil end end commands.reload = function(env, read, on_values, on_error) - local function _651_(_241) + local function _628_(_241) return reload(tostring(_241), env, on_values, on_error) end - return run_command(read, on_error, _651_) + return run_command(read, on_error, _628_) end do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.") commands.reset = function(env, _, on_values) @@ -237,119 +265,111 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.") commands.complete = function(env, read, on_values, on_error, scope, chars) - local function _652_() + local function _629_() return on_values(completer(env, scope, string.char(unpack(chars)):gsub(",complete +", ""):sub(1, -2))) end - return run_command(read, on_error, _652_) + return run_command(read, on_error, _629_) end do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input symbol.") local function apropos_2a(pattern, tbl, prefix, seen, names) for name, subtbl in pairs(tbl) do if (("string" == type(name)) and (package ~= subtbl)) then - local _653_ = type(subtbl) - if (_653_ == "function") then + local _630_0 = type(subtbl) + if (_630_0 == "function") then if ((prefix .. name)):match(pattern) then table.insert(names, (prefix .. name)) - else end - elseif (_653_ == "table") then + elseif (_630_0 == "table") then if not seen[subtbl] then - local _656_ + local _632_ do - local _655_ = seen - _655_[subtbl] = true - _656_ = _655_ + seen[subtbl] = true + _632_ = seen end - apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _656_, names) - else + apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _632_, names) end - else end - else end end return names end local function apropos(pattern) local names = apropos_2a(pattern, package.loaded, "", {}, {}) - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, name in ipairs(names) do - local val_16_auto = name:gsub("^_G%.", "") - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = name:gsub("^_G%.", "") + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_14_auto + return tbl_17_ end commands.apropos = function(_env, read, on_values, on_error, _scope) - local function _661_(_241) + local function _637_(_241) return on_values(apropos(tostring(_241))) end - return run_command(read, on_error, _661_) + return run_command(read, on_error, _637_) end do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.") local function apropos_follow_path(path) - local paths + local paths = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for p in path:gmatch("[^%.]+") do - local val_16_auto = p - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = p + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - paths = tbl_14_auto + paths = tbl_17_ end local tgt = package.loaded for _, path0 in ipairs(paths) do if (nil == tgt) then break end - local _664_ + local _640_ do - local _663_ = path0:gsub("%/", ".") - _664_ = _663_ + local _639_0 = path0:gsub("%/", ".") + _640_ = _639_0 end - tgt = tgt[_664_] + tgt = tgt[_640_] end return tgt end local function apropos_doc(pattern) - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, path in ipairs(apropos(".*")) do - local val_16_auto + local val_19_ = nil do local tgt = apropos_follow_path(path) if ("function" == type(tgt)) then - local _665_ = (compiler.metadata):get(tgt, "fnl/docstring") - if (nil ~= _665_) then - local docstr = _665_ - val_16_auto = (docstr:match(pattern) and path) + local _641_0 = (compiler.metadata):get(tgt, "fnl/docstring") + if (nil ~= _641_0) then + local docstr = _641_0 + val_19_ = (docstr:match(pattern) and path) else - val_16_auto = nil + val_19_ = nil end else - val_16_auto = nil + val_19_ = nil end end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_14_auto + return tbl_17_ end commands["apropos-doc"] = function(_env, read, on_values, on_error, _scope) - local function _669_(_241) + local function _645_(_241) return on_values(apropos_doc(tostring(_241))) end - return run_command(read, on_error, _669_) + return run_command(read, on_error, _645_) end do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs") local function apropos_show_docs(on_values, pattern) @@ -358,124 +378,115 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) if (("function" == type(tgt)) and (compiler.metadata):get(tgt, "fnl/docstring")) then on_values(specials.doc(tgt, path)) on_values() - else end end return nil end commands["apropos-show-docs"] = function(_env, read, on_values, on_error) - local function _671_(_241) + local function _647_(_241) return apropos_show_docs(on_values, tostring(_241)) end - return run_command(read, on_error, _671_) + return run_command(read, on_error, _647_) end do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name") - local function resolve(identifier, _672_, scope) - local _arg_673_ = _672_ - local ___replLocals___ = _arg_673_["___replLocals___"] - local env = _arg_673_ - local e - local function _674_(_241, _242) + local function resolve(identifier, _648_0, scope) + local _649_ = _648_0 + local env = _649_ + local ___replLocals___ = _649_["___replLocals___"] + local e = nil + local function _650_(_241, _242) return (___replLocals___[_242] or env[_242]) end - e = setmetatable({}, {__index = _674_}) - local _675_, _676_ = pcall(compiler["compile-string"], tostring(identifier), {scope = scope}) - if ((_675_ == true) and (nil ~= _676_)) then - local code = _676_ + e = setmetatable({}, {__index = _650_}) + local _651_0, _652_0 = pcall(compiler["compile-string"], tostring(identifier), {scope = scope}) + if ((_651_0 == true) and (nil ~= _652_0)) then + local code = _652_0 return specials["load-code"](code, e)() - else - return nil end end commands.find = function(env, read, on_values, on_error, scope) - local function _678_(_241) - local _679_ + local function _654_(_241) + local _655_0 = nil do - local _680_ = utils["sym?"](_241) - if (nil ~= _680_) then - local _681_ = resolve(_680_, env, scope) - if (nil ~= _681_) then - _679_ = debug.getinfo(_681_) + local _656_0 = utils["sym?"](_241) + if (nil ~= _656_0) then + local _657_0 = resolve(_656_0, env, scope) + if (nil ~= _657_0) then + _655_0 = debug.getinfo(_657_0) else - _679_ = _681_ + _655_0 = _657_0 end else - _679_ = _680_ + _655_0 = _656_0 end end - if ((_G.type(_679_) == "table") and ((_679_).what == "Lua") and (nil ~= (_679_).source) and (nil ~= (_679_).linedefined) and (nil ~= (_679_).short_src)) then - local source = (_679_).source - local line = (_679_).linedefined - local src = (_679_).short_src - local fnlsrc + if ((_G.type(_655_0) == "table") and (nil ~= _655_0.linedefined) and (nil ~= _655_0.short_src) and (nil ~= _655_0.source) and (_655_0.what == "Lua")) then + local line = _655_0.linedefined + local src = _655_0.short_src + local source = _655_0.source + local fnlsrc = nil do - local t_684_ = compiler.sourcemap - if (nil ~= t_684_) then - t_684_ = (t_684_)[source] - else + local _660_0 = compiler.sourcemap + if (nil ~= _660_0) then + _660_0 = _660_0[source] end - if (nil ~= t_684_) then - t_684_ = (t_684_)[line] - else + if (nil ~= _660_0) then + _660_0 = _660_0[line] end - if (nil ~= t_684_) then - t_684_ = (t_684_)[2] - else + if (nil ~= _660_0) then + _660_0 = _660_0[2] end - fnlsrc = t_684_ + fnlsrc = _660_0 end return on_values({string.format("%s:%s", src, (fnlsrc or line))}) - elseif (_679_ == nil) then + elseif (_655_0 == nil) then return on_error("Repl", "Unknown value") - elseif true then - local _ = _679_ - return on_error("Repl", "No source info") else - return nil + local _ = _655_0 + return on_error("Repl", "No source info") end end - return run_command(read, on_error, _678_) + return run_command(read, on_error, _654_) end do end (compiler.metadata):set(commands.find, "fnl/docstring", "Print the filename and line number for a given function") commands.doc = function(env, read, on_values, on_error, scope) - local function _689_(_241) + local function _665_(_241) local name = tostring(_241) local path = (utils["multi-sym?"](name) or {name}) local ok_3f, target = nil, nil - local function _690_() + local function _666_() return (utils["get-in"](scope.specials, path) or utils["get-in"](scope.macros, path) or resolve(name, env, scope)) end - ok_3f, target = pcall(_690_) + ok_3f, target = pcall(_666_) if ok_3f then return on_values({specials.doc(target, name)}) else return on_error("Repl", "Could not resolve value for docstring lookup") end end - return run_command(read, on_error, _689_) + return run_command(read, on_error, _665_) end do end (compiler.metadata):set(commands.doc, "fnl/docstring", "Print the docstring and arglist for a function, macro, or special form.") commands.compile = function(env, read, on_values, on_error, scope) - local function _692_(_241) + local function _668_(_241) local allowedGlobals = specials["current-global-names"](env) - local ok_3f, result = pcall(compiler.compile, _241, {env = env, scope = scope, allowedGlobals = allowedGlobals}) + local ok_3f, result = pcall(compiler.compile, _241, {allowedGlobals = allowedGlobals, env = env, scope = scope}) if ok_3f then return on_values({result}) else return on_error("Repl", ("Error compiling expression: " .. result)) end end - return run_command(read, on_error, _692_) + return run_command(read, on_error, _668_) end do end (compiler.metadata):set(commands.compile, "fnl/docstring", "compiles the expression into lua and prints the result.") local function load_plugin_commands(plugins) for _, plugin in ipairs((plugins or {})) do for name, f in pairs(plugin) do - local _694_ = name:match("^repl%-command%-(.*)") - if (nil ~= _694_) then - local cmd_name = _694_ + local _670_0 = name:match("^repl%-command%-(.*)") + if (nil ~= _670_0) then + local cmd_name = _670_0 commands[cmd_name] = (commands[cmd_name] or f) - else end end end @@ -484,50 +495,29 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars) local command_name = input:match(",([^%s/]+)") do - local _696_ = commands[command_name] - if (nil ~= _696_) then - local command = _696_ + local _672_0 = commands[command_name] + if (nil ~= _672_0) then + local command = _672_0 command(env, read, on_values, on_error, scope, chars) - elseif true then - local _ = _696_ + else + local _ = _672_0 if ("exit" ~= command_name) then on_values({"Unknown command", command_name}) - else end - else end end if ("exit" ~= command_name) then return loop() - else - return nil end end local function try_readline_21(opts, ok, readline) if ok then if readline.set_readline_name then readline.set_readline_name("fennel") - else - end - do - local rl_opts - do - local tbl_11_auto = {keeplines = 1000, histfile = ""} - for k, v in pairs(readline.set_options({})) do - local _701_, _702_ = k, v - if ((nil ~= _701_) and (nil ~= _702_)) then - local k_12_auto = _701_ - local v_13_auto = _702_ - tbl_11_auto[k_12_auto] = v_13_auto - else - end - end - rl_opts = tbl_11_auto - end - readline.set_options(rl_opts) end + readline.set_options({histfile = "", keeplines = 1000}) opts.readChunk = function(parser_state) - local prompt + local prompt = nil if (0 < parser_state["stack-size"]) then prompt = ".. " else @@ -536,8 +526,6 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local str = readline.readline(prompt) if str then return (str .. "\n") - else - return nil end end local completer0 = nil @@ -555,8 +543,6 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end readline.set_complete_function(repl_completer) return readline - else - return nil end end local function should_use_readline_3f(opts) @@ -564,8 +550,19 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end local function repl(_3foptions) local old_root_options = utils.root.options - local opts = ((_3foptions and utils.copy(_3foptions)) or {}) + local _681_ = utils.copy(_3foptions) + local opts = _681_ + local _3ffennelrc = _681_["fennelrc"] + local _ = nil + opts.fennelrc = nil + _ = nil local readline = (should_use_readline_3f(opts) and try_readline_21(opts, pcall(require, "readline"))) + local _0 = nil + if _3ffennelrc then + _0 = _3ffennelrc() + else + _0 = nil + end local env = specials["wrap-env"]((opts.env or rawget(_G, "_ENV") or _G)) local save_locals_3f = (opts.saveLocals ~= false) local read_chunk = (opts.readChunk or default_read_chunk) @@ -575,41 +572,35 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local byte_stream, clear_stream = parser.granulate(read_chunk) local chars = {} local read, reset = nil, nil - local function _708_(parser_state) + local function _683_(parser_state) local c = byte_stream(parser_state) table.insert(chars, c) return c end - read, reset = parser.parser(_708_) + read, reset = parser.parser(_683_) opts.env, opts.scope = env, compiler["make-scope"]() opts.useMetadata = (opts.useMetadata ~= false) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](env) - else end if opts.registerCompleter then - local function _712_() - local _710_ = env - local _711_ = opts.scope - local function _713_(...) - return completer(_710_, _711_, ...) + local function _686_() + local _685_0 = opts.scope + local function _687_(...) + return completer(env, _685_0, ...) end - return _713_ + return _687_ end - opts.registerCompleter(_712_()) - else + opts.registerCompleter(_686_()) end load_plugin_commands(opts.plugins) if save_locals_3f then local function newindex(t, k, v) if opts.scope.unmanglings[k] then return rawset(t, k, v) - else - return nil end end env.___replLocals___ = setmetatable({}, {__newindex = newindex}) - else end local function print_values(...) local vals = {...} @@ -625,8 +616,10 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) chars[k] = nil end reset() - local ok, not_eof_3f, x = pcall(read) + local ok, parser_not_eof_3f, x = pcall(read) local src_string = string.char(unpack(chars)) + local readline_not_eof_3f = (not readline or (src_string ~= "(null)")) + local not_eof_3f = (readline_not_eof_3f and parser_not_eof_3f) if not ok then on_error("Parse", not_eof_3f) clear_stream() @@ -636,60 +629,50 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) else if not_eof_3f then do - local _717_, _718_ = nil, nil - local function _720_() - local _719_ = opts - _719_["source"] = src_string - return _719_ + local _691_0, _692_0 = nil, nil + local function _693_() + opts["source"] = src_string + return opts end - _717_, _718_ = pcall(compiler.compile, x, _720_()) - if ((_717_ == false) and (nil ~= _718_)) then - local msg = _718_ + _691_0, _692_0 = pcall(compiler.compile, x, _693_()) + if ((_691_0 == false) and (nil ~= _692_0)) then + local msg = _692_0 clear_stream() on_error("Compile", msg) - elseif ((_717_ == true) and (nil ~= _718_)) then - local src = _718_ - local src0 + elseif ((_691_0 == true) and (nil ~= _692_0)) then + local src = _692_0 + local src0 = nil if save_locals_3f then src0 = splice_save_locals(env, src, opts.scope) else src0 = src end - local _722_, _723_ = pcall(specials["load-code"], src0, env) - if ((_722_ == false) and (nil ~= _723_)) then - local msg = _723_ + local _695_0, _696_0 = pcall(specials["load-code"], src0, env) + if ((_695_0 == false) and (nil ~= _696_0)) then + local msg = _696_0 clear_stream() on_error("Lua Compile", msg, src0) - elseif (true and (nil ~= _723_)) then - local _ = _722_ - local chunk = _723_ - local function _724_() + elseif (true and (nil ~= _696_0)) then + local _1 = _695_0 + local chunk = _696_0 + local function _697_() return print_values(chunk()) end - local function _725_() - local function _726_(...) - return on_error("Runtime", ...) - end - return _726_ + local function _698_(...) + return on_error("Runtime", ...) end - xpcall(_724_, _725_()) - else + xpcall(_697_, _698_) end - else end end utils.root.options = old_root_options return loop() - else - return nil end end end loop() if readline then return readline.save_history() - else - return nil end end return repl @@ -702,14 +685,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local unpack = (table.unpack or _G.unpack) local SPECIALS = compiler.scopes.global.specials local function wrap_env(env) - local function _416_(_, key) + local function _407_(_, key) if utils["string?"](key) then return env[compiler["global-unmangling"](key)] else return env[key] end end - local function _418_(_, key, value) + local function _409_(_, key, value) if utils["string?"](key) then env[compiler["global-unmangling"](key)] = value return nil @@ -718,60 +701,54 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return nil end end - local function _420_() + local function _411_() local function putenv(k, v) - local _421_ + local _412_ if utils["string?"](k) then - _421_ = compiler["global-unmangling"](k) + _412_ = compiler["global-unmangling"](k) else - _421_ = k + _412_ = k end - return _421_, v + return _412_, v end return next, utils.kvmap(env, putenv), nil end - return setmetatable({}, {__index = _416_, __newindex = _418_, __pairs = _420_}) + return setmetatable({}, {__index = _407_, __newindex = _409_, __pairs = _411_}) end local function current_global_names(_3fenv) - local mt + local mt = nil do - local _423_ = getmetatable(_3fenv) - if ((_G.type(_423_) == "table") and (nil ~= (_423_).__pairs)) then - local mtpairs = (_423_).__pairs - local tbl_11_auto = {} + local _414_0 = getmetatable(_3fenv) + if ((_G.type(_414_0) == "table") and (nil ~= _414_0.__pairs)) then + local mtpairs = _414_0.__pairs + local tbl_14_ = {} for k, v in mtpairs(_3fenv) do - local _424_, _425_ = k, v - if ((nil ~= _424_) and (nil ~= _425_)) then - local k_12_auto = _424_ - local v_13_auto = _425_ - tbl_11_auto[k_12_auto] = v_13_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - mt = tbl_11_auto - elseif (_423_ == nil) then + mt = tbl_14_ + elseif (_414_0 == nil) then mt = (_3fenv or _G) else - mt = nil + mt = nil end end return (mt and utils.kvmap(mt, compiler["global-unmangling"])) end local function load_code(code, _3fenv, _3ffilename) local env = (_3fenv or rawget(_G, "_ENV") or _G) - local _428_, _429_ = rawget(_G, "setfenv"), rawget(_G, "loadstring") - if ((nil ~= _428_) and (nil ~= _429_)) then - local setfenv = _428_ - local loadstring = _429_ + local _417_0, _418_0 = rawget(_G, "setfenv"), rawget(_G, "loadstring") + if ((nil ~= _417_0) and (nil ~= _418_0)) then + local setfenv = _417_0 + local loadstring = _418_0 local f = assert(loadstring(code, _3ffilename)) - local _430_ = f - setfenv(_430_, env) - return _430_ - elseif true then - local _ = _428_ - return assert(load(code, _3ffilename, "t", env)) + setfenv(f, env) + return f else - return nil + local _ = _417_0 + return assert(load(code, _3ffilename, "t", env)) end end local function doc_2a(tgt, name) @@ -782,20 +759,20 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local mt = getmetatable(tgt) if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#"}), " ") - local _432_ + local _420_ if (0 < #arglist) then - _432_ = " " + _420_ = " " else - _432_ = "" + _420_ = "" end - return string.format("(%s%s%s)\n %s", name, _432_, arglist, docstring) + return string.format("(%s%s%s)\n %s", name, _420_, arglist, docstring) else return string.format("%s\n %s", name, docstring) end end end local function doc_special(name, arglist, docstring, body_form_3f) - compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/docstring"] = docstring, ["fnl/body-form?"] = body_form_3f} + compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/body-form?"] = body_form_3f, ["fnl/docstring"] = docstring} return nil end local function compile_do(ast, scope, parent, _3fstart) @@ -824,7 +801,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local subexprs = compiler.compile1(ast[i], sub_scope, chunk, subopts) if (i ~= len) then compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) - else end end end @@ -839,8 +815,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct elseif opts.nval then local syms = {} for i = 1, opts.nval do - local s = ((_3fpre_syms and (_3fpre_syms)[i]) or compiler.gensym(scope)) - do end (syms)[i] = s + local s = ((_3fpre_syms and _3fpre_syms[i]) or compiler.gensym(scope)) + syms[i] = s retexprs[i] = utils.expr(s, "sym") end local outer_target = table.concat(syms, ", ") @@ -849,7 +825,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compile_body(outer_target, opts.tail) else local fname = compiler.gensym(scope) - local fargs + local fargs = nil if scope.vararg then fargs = "..." else @@ -870,97 +846,91 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct for j = 2, #subexprs do table.insert(exprs, subexprs[j]) end - else end end return exprs end doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.") - local function deep_tostring(x, key_3f) - if utils["list?"](x) then - local _441_ - do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for _, v in ipairs(x) do - local val_16_auto = deep_tostring(v) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else - end - end - _441_ = tbl_14_auto - end - return ("(" .. table.concat(_441_, " ") .. ")") - elseif utils["sequence?"](x) then - local _443_ - do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for _, v in ipairs(x) do - local val_16_auto = deep_tostring(v) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else - end - end - _443_ = tbl_14_auto - end - return ("[" .. table.concat(_443_, " ") .. "]") - elseif utils["table?"](x) then - local _445_ - do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for k, v in utils.stablepairs(x) do - local val_16_auto = (deep_tostring(k, true) .. " " .. deep_tostring(v)) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else - end - end - _445_ = tbl_14_auto - end - return ("{" .. table.concat(_445_, " ") .. "}") - elseif (key_3f and utils["string?"](x) and x:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then - return (":" .. x) - elseif utils["string?"](x) then - return string.format("%q", x):gsub("\\\"", "\\\\\""):gsub("\"", "\\\"") - else - return tostring(x) + local function __3estack(stack, tbl) + for k, v in pairs(tbl) do + table.insert(stack, k) + table.insert(stack, v) end + return stack end - local function set_fn_metadata(arg_list, docstring, parent, fn_name) - if utils.root.options.useMetadata then - local args - local function _448_(_241) - return ("\"%s\""):format(deep_tostring(_241)) + local function literal_3f(val) + local res = true + if utils["list?"](val) then + res = false + elseif utils["table?"](val) then + local stack = __3estack({}, val) + for _, elt in ipairs(stack) do + if not res then break end + if utils["list?"](elt) then + res = false + elseif utils["table?"](elt) then + __3estack(stack, elt) + end end - args = utils.map(arg_list, _448_) - local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")} - if docstring then - table.insert(meta_fields, "\"fnl/docstring\"") - table.insert(meta_fields, ("\"" .. docstring:gsub("%s+$", ""):gsub("\\", "\\\\"):gsub("\n", "\\n"):gsub("\"", "\\\"") .. "\"")) + end + return res + end + local function compile_value(v) + local opts = {nval = 1, tail = false} + local scope = compiler["make-scope"]() + local chunk = {} + local _431_ = compiler.compile1(v, scope, chunk, opts) + local _432_ = _431_[1] + local v0 = _432_[1] + return v0 + end + local function insert_meta(meta, k, v) + local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true} + compiler.assert((type(k) == "string"), ("expected string keys in metadata table, got: %s"):format(view(k, view_opts))) + compiler.assert(literal_3f(v), ("expected literal value in metadata table, got: %s %s"):format(view(k, view_opts), view(v, view_opts))) + table.insert(meta, view(k)) + local function _433_() + if ("string" == type(v)) then + return view(v, view_opts) else + return compile_value(v) + end + end + table.insert(meta, _433_()) + return meta + end + local function insert_arglist(meta, arg_list) + local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true} + table.insert(meta, "\"fnl/arglist\"") + local function _434_(_241) + return view(view(_241, view_opts)) + end + table.insert(meta, ("{" .. table.concat(utils.map(arg_list, _434_), ", ") .. "}")) + return meta + end + local function set_fn_metadata(f_metadata, parent, fn_name) + if utils.root.options.useMetadata then + local meta_fields = {} + for k, v in utils.stablepairs(f_metadata) do + if (k == "fnl/arglist") then + insert_arglist(meta_fields, v) + else + insert_meta(meta_fields, k, v) + end end local meta_str = ("require(\"%s\").metadata"):format((utils.root.options.moduleName or "fennel")) return compiler.emit(parent, ("pcall(function() %s:setall(%s, %s) end)"):format(meta_str, fn_name, table.concat(meta_fields, ", "))) - else - return nil end end local function get_fn_name(ast, scope, fn_name, multi) if (fn_name and (fn_name[1] ~= "nil")) then - local _451_ + local _437_ if not multi then - _451_ = compiler["declare-local"](fn_name, {}, scope, ast) + _437_ = compiler["declare-local"](fn_name, {}, scope, ast) else - _451_ = (compiler["symbol-to-expression"](fn_name, scope))[1] + _437_ = compiler["symbol-to-expression"](fn_name, scope)[1] end - return _451_, not multi, 3 + return _437_, not multi, 3 else return nil, true, 2 end @@ -970,16 +940,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct for i = (index + 1), #ast do compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)}) end - local _454_ + local _440_ if local_3f then - _454_ = "local function %s(%s)" + _440_ = "local function %s(%s)" else - _454_ = "%s = function(%s)" + _440_ = "%s = function(%s)" end - compiler.emit(parent, string.format(_454_, fn_name, table.concat(arg_name_list, ", ")), ast) + compiler.emit(parent, string.format(_440_, fn_name, table.concat(arg_name_list, ", ")), ast) compiler.emit(parent, f_chunk, ast) compiler.emit(parent, "end", ast) - set_fn_metadata(f_metadata["fnl/arglist"], f_metadata["fnl/docstring"], parent, fn_name) + set_fn_metadata(f_metadata, parent, fn_name) utils.hook("fn", ast, f_scope) return utils.expr(fn_name, "sym") end @@ -987,44 +957,52 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local fn_name = compiler.gensym(scope) return compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, true, arg_name_list, f_metadata) end + local function assoc_table_3f(t) + local len = #t + local nxt, t0, k = pairs(t) + local function _442_() + if (len == 0) then + return k + else + return len + end + end + return (nil ~= nxt(t0, _442_())) + end local function get_function_metadata(ast, arg_list, index) local f_metadata = {["fnl/arglist"] = arg_list} local index_2a = (index + 1) local expr = ast[index_2a] if (utils["string?"](expr) and (index_2a < #ast)) then - local _457_ + local _443_ do - local _456_ = f_metadata - _456_["fnl/docstring"] = expr - _457_ = _456_ + f_metadata["fnl/docstring"] = expr + _443_ = f_metadata end - return _457_, index_2a - elseif (utils["table?"](expr) and (index_2a < #ast)) then - local _458_ + return _443_, index_2a + elseif (utils["table?"](expr) and (index_2a < #ast) and assoc_table_3f(expr)) then + local _444_ do - local tbl_11_auto = f_metadata + local tbl_14_ = f_metadata for k, v in pairs(expr) do - local _459_, _460_ = k, v - if ((nil ~= _459_) and (nil ~= _460_)) then - local k_12_auto = _459_ - local v_13_auto = _460_ - tbl_11_auto[k_12_auto] = v_13_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _458_ = tbl_11_auto + _444_ = tbl_14_ end - return _458_, index_2a + return _444_, index_2a else return f_metadata, index end end SPECIALS.fn = function(ast, scope, parent) - local f_scope + local f_scope = nil do - local _463_ = compiler["make-scope"](scope) - do end (_463_)["vararg"] = false - f_scope = _463_ + local _447_0 = compiler["make-scope"](scope) + _447_0["vararg"] = false + f_scope = _447_0 end local f_chunk = {} local fn_sym = utils["sym?"](ast[2]) @@ -1032,23 +1010,48 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local fn_name, local_3f, index = get_fn_name(ast, scope, fn_sym, multi) local arg_list = compiler.assert(utils["table?"](ast[index]), "expected parameters table", ast) compiler.assert((not multi or not multi["multi-sym-method-call"]), ("unexpected multi symbol " .. tostring(fn_name)), fn_sym) - local function get_arg_name(arg) - if utils["varg?"](arg) then + local function destructure_arg(arg) + local raw = utils.sym(compiler.gensym(scope)) + local declared = compiler["declare-local"](raw, {}, f_scope, ast) + compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) + return declared + end + local function destructure_amp(i) + compiler.assert((i == (#arg_list - 1)), "expected rest argument before last parameter", arg_list[(i + 1)], arg_list) + f_scope.vararg = true + compiler.destructure(arg_list[#arg_list], {utils.varg()}, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) + return "..." + end + local function get_arg_name(arg, i) + if f_scope.vararg then + return nil + elseif utils["varg?"](arg) then compiler.assert((arg == arg_list[#arg_list]), "expected vararg as last parameter", ast) f_scope.vararg = true return "..." + elseif (utils.sym("&") == arg) then + return destructure_amp(i) elseif (utils["sym?"](arg) and (tostring(arg) ~= "nil") and not utils["multi-sym?"](tostring(arg))) then return compiler["declare-local"](arg, {}, f_scope, ast) elseif utils["table?"](arg) then - local raw = utils.sym(compiler.gensym(scope)) - local declared = compiler["declare-local"](raw, {}, f_scope, ast) - compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) - return declared + return destructure_arg(arg) else return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[index]) end end - local arg_name_list = utils.map(arg_list, get_arg_name) + local arg_name_list = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i, a in ipairs(arg_list) do + local val_19_ = get_arg_name(a, i) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + arg_name_list = tbl_17_ + end local f_metadata, index0 = get_function_metadata(ast, arg_list, index) if fn_name then return compile_named_fn(ast, f_scope, f_chunk, parent, index0, fn_name, local_3f, arg_name_list, f_metadata) @@ -1059,39 +1062,36 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring or a metadata table.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.", true) SPECIALS.lua = function(ast, _, parent) compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast) - local _467_ + local _452_ do - local _466_ = utils["sym?"](ast[2]) - if (nil ~= _466_) then - _467_ = tostring(_466_) + local _451_0 = utils["sym?"](ast[2]) + if (nil ~= _451_0) then + _452_ = tostring(_451_0) else - _467_ = _466_ + _452_ = _451_0 end end - if ("nil" ~= _467_) then + if ("nil" ~= _452_) then table.insert(parent, {ast = ast, leaf = tostring(ast[2])}) - else end - local _471_ + local _456_ do - local _470_ = utils["sym?"](ast[3]) - if (nil ~= _470_) then - _471_ = tostring(_470_) + local _455_0 = utils["sym?"](ast[3]) + if (nil ~= _455_0) then + _456_ = tostring(_455_0) else - _471_ = _470_ + _456_ = _455_0 end end - if ("nil" ~= _471_) then + if ("nil" ~= _456_) then return tostring(ast[3]) - else - return nil end end local function dot(ast, scope, parent) compiler.assert((1 < #ast), "expected table argument", ast) local len = #ast - local _let_474_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) - local lhs = _let_474_[1] + local _459_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local lhs = _459_[1] if (len == 2) then return tostring(lhs) else @@ -1101,8 +1101,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (utils["string?"](index) and utils["valid-lua-identifier?"](index)) then table.insert(indices, ("." .. index)) else - local _let_475_ = compiler.compile1(index, scope, parent, {nval = 1}) - local index0 = _let_475_[1] + local _460_ = compiler.compile1(index, scope, parent, {nval = 1}) + local index0 = _460_[1] table.insert(indices, ("[" .. tostring(index0) .. "]")) end end @@ -1147,26 +1147,25 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end doc_special("var", {"name", "val"}, "Introduce new mutable local.") local function kv_3f(t) - local _479_ + local _464_ do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for k in pairs(t) do - local val_16_auto + local val_19_ = nil if ("number" ~= type(k)) then - val_16_auto = k + val_19_ = k else - val_16_auto = nil + val_19_ = nil end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _479_ = tbl_14_auto + _464_ = tbl_17_ end - return (_479_)[1] + return _464_[1] end SPECIALS.let = function(ast, scope, parent, opts) local bindings = ast[2] @@ -1193,29 +1192,27 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end local function disambiguate_3f(rootstr, parent) - local function _484_() - local _483_ = get_prev_line(parent) - if (nil ~= _483_) then - local prev_line = _483_ + local function _469_() + local _468_0 = get_prev_line(parent) + if (nil ~= _468_0) then + local prev_line = _468_0 return prev_line:match("%)$") - else - return nil end end - return (rootstr:match("^{") or _484_()) + return (rootstr:match("^{") or _469_()) end SPECIALS.tset = function(ast, scope, parent) compiler.assert((3 < #ast), "expected table, key, and value arguments", ast) - local root = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] + local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] local keys = {} for i = 3, (#ast - 1) do - local _let_486_ = compiler.compile1(ast[i], scope, parent, {nval = 1}) - local key = _let_486_[1] + local _471_ = compiler.compile1(ast[i], scope, parent, {nval = 1}) + local key = _471_[1] table.insert(keys, tostring(key)) end - local value = (compiler.compile1(ast[#ast], scope, parent, {nval = 1}))[1] + local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1] local rootstr = tostring(root) - local fmtstr + local fmtstr = nil if disambiguate_3f(rootstr, parent) then fmtstr = "do end (%s)[%s] = %s" else @@ -1232,7 +1229,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local target_exprs = {} for i = 1, opts.nval do local s = compiler.gensym(scope) - do end (accum)[i] = s + accum[i] = s target_exprs[i] = utils.expr(s, "sym") end return "target", opts.tail, table.concat(accum, ", "), target_exprs @@ -1254,7 +1251,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end if (1 == (#ast % 2)) then table.insert(ast, utils.sym("nil")) - else end for i = 2, (#ast - 1), 2 do local condchunk = {} @@ -1272,7 +1268,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local last_buffer = buffer for i = 1, #branches do local branch = branches[i] - local fstr + local fstr = nil if not branch.nested then fstr = "if %s then" else @@ -1293,13 +1289,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.emit(last_buffer, "else", ast) compiler.emit(last_buffer, else_branch.chunk, ast) compiler.emit(last_buffer, "end", ast) - elseif not (branches[(i + 1)]).nested then + elseif not branches[(i + 1)].nested then local next_buffer = {} compiler.emit(last_buffer, "else", ast) compiler.emit(last_buffer, next_buffer, ast) compiler.emit(last_buffer, "end", ast) last_buffer = next_buffer - else end end if (wrapper == "iife") then @@ -1328,17 +1323,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if ((utils["sym?"](last_item) and (tostring(last_item) == "&until")) or ("until" == last_item)) then table.remove(bindings, (#bindings - 1)) return table.remove(bindings) - else - return nil end end local function compile_until(condition, scope, chunk) if condition then - local _let_495_ = compiler.compile1(condition, scope, chunk, {nval = 1}) - local condition_lua = _let_495_[1] + local _480_ = compiler.compile1(condition, scope, chunk, {nval = 1}) + local condition_lua = _480_[1] return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(condition, "expression")) - else - return nil end end SPECIALS.each = function(ast, scope, parent) @@ -1356,7 +1347,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compiler["declare-local"](v, {}, sub_scope, ast, new_manglings) else local raw = utils.sym(compiler.gensym(sub_scope)) - do end (destructures)[raw] = v + destructures[raw] = v return compiler["declare-local"](raw, {}, sub_scope, ast) end end @@ -1377,13 +1368,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("each", {"[key value (iterator)]", "..."}, "Runs the body once for each set of values provided by the given iterator.\nMost commonly used with ipairs for sequential tables or pairs for undefined\norder, but can be used with any iterator.", true) local function while_2a(ast, scope, parent) local len1 = #parent - local condition = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] + local condition = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] local len2 = #parent local sub_chunk = {} if (len1 ~= len2) then for i = (len1 + 1), len2 do table.insert(sub_chunk, parent[i]) - do end (parent)[i] = nil + parent[i] = nil end compiler.emit(parent, "while true do", ast) compiler.emit(sub_chunk, ("if not %s then break end"):format(condition[1]), ast) @@ -1407,7 +1398,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.assert((3 <= #ast), "expected body expression", ast[1]) compiler.assert((#ranges <= 3), "unexpected arguments", ranges[4]) for i = 1, math.min(#ranges, 3) do - range_args[i] = tostring((compiler.compile1(ranges[i], scope, parent, {nval = 1}))[1]) + range_args[i] = tostring(compiler.compile1(ranges[i], scope, parent, {nval = 1})[1]) end compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast) compile_until(until_condition, sub_scope, chunk) @@ -1418,11 +1409,11 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct SPECIALS["for"] = for_2a doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).", true) local function native_method_call(ast, _scope, _parent, target, args) - local _let_499_ = ast - local _ = _let_499_[1] - local _0 = _let_499_[2] - local method_string = _let_499_[3] - local call_string + local _484_ = ast + local _ = _484_[1] + local _0 = _484_[2] + local method_string = _484_[3] + local call_string = nil if ((target.type == "literal") or (target.type == "varg") or (target.type == "expression")) then call_string = "(%s):%s(%s)" else @@ -1431,30 +1422,30 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return utils.expr(string.format(call_string, tostring(target), method_string, table.concat(args, ", ")), "statement") end local function nonnative_method_call(ast, scope, parent, target, args) - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) + local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1]) local args0 = {tostring(target), unpack(args)} return utils.expr(string.format("%s[%s](%s)", tostring(target), method_string, table.concat(args0, ", ")), "statement") end local function double_eval_protected_method_call(ast, scope, parent, target, args) - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) + local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1]) local call = "(function(tgt, m, ...) return tgt[m](tgt, ...) end)(%s, %s)" table.insert(args, 1, method_string) return utils.expr(string.format(call, tostring(target), table.concat(args, ", ")), "statement") end local function method_call(ast, scope, parent) compiler.assert((2 < #ast), "expected at least 2 arguments", ast) - local _let_501_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) - local target = _let_501_[1] + local _486_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local target = _486_[1] local args = {} for i = 4, #ast do - local subexprs - local _502_ + local subexprs = nil + local _487_ if (i ~= #ast) then - _502_ = 1 + _487_ = 1 else - _502_ = nil + _487_ = nil end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _502_}) + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _487_}) utils.map(subexprs, tostring, args) end if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then @@ -1476,7 +1467,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.", true) local function hashfn_max_used(f_scope, i, max) - local max0 + local max0 = nil if f_scope.symmeta[("$" .. i)].used then max0 = i else @@ -1490,12 +1481,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end SPECIALS.hashfn = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) - local f_scope + local f_scope = nil do - local _507_ = compiler["make-scope"](scope) - do end (_507_)["vararg"] = false - _507_["hashfn"] = true - f_scope = _507_ + local _492_0 = compiler["make-scope"](scope) + _492_0["vararg"] = false + _492_0["hashfn"] = true + f_scope = _492_0 end local f_chunk = {} local name = compiler.gensym(scope) @@ -1511,7 +1502,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct f_scope.vararg = true return nil else - return (utils["list?"](node) or utils["table?"](node)) + return (("table" == type(node)) and (utils.sym("hashfn") ~= node[1]) and (utils["list?"](node) or utils["table?"](node))) end end utils["walk-tree"](ast[2], walker) @@ -1519,9 +1510,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local max_used = hashfn_max_used(f_scope, 1, 0) if f_scope.vararg then compiler.assert((max_used == 0), "$ and $... in hashfn are mutually exclusive", ast) - else end - local arg_str + local arg_str = nil if f_scope.vararg then arg_str = tostring(utils.varg()) else @@ -1533,9 +1523,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return utils.expr(name, "sym") end doc_special("hashfn", {"..."}, "Function literal shorthand; args are either $... OR $1, $2, etc.") - local function maybe_short_circuit_protect(ast, i, name, _511_) - local _arg_512_ = _511_ - local mac = _arg_512_["macros"] + local function maybe_short_circuit_protect(ast, i, name, _496_0) + local _497_ = _496_0 + local mac = _497_["macros"] local call = (utils["list?"](ast) and tostring(ast[1])) if ((("or" == name) or ("and" == name)) and (1 < i) and (mac[call] or ("set" == call) or ("tset" == call) or ("global" == call))) then return utils.list(utils.sym("do"), ast) @@ -1556,40 +1546,35 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct table.insert(operands, tostring(subexprs[1])) end end - local _515_ = #operands - if (_515_ == 0) then - local _517_ + local _500_0 = #operands + if (_500_0 == 0) then + local _501_ do - local _516_ = zero_arity - compiler.assert(_516_, "Expected more than 0 arguments", ast) - _517_ = _516_ + compiler.assert(zero_arity, "Expected more than 0 arguments", ast) + _501_ = zero_arity end - return utils.expr(_517_, "literal") - elseif (_515_ == 1) then + return utils.expr(_501_, "literal") + elseif (_500_0 == 1) then if unary_prefix then return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")") else return operands[1] end - elseif true then - local _ = _515_ - return ("(" .. table.concat(operands, padded_op) .. ")") else - return nil + local _ = _500_0 + return ("(" .. table.concat(operands, padded_op) .. ")") end end local function define_arithmetic_special(name, zero_arity, unary_prefix, _3flua_name) - local _523_ + local _505_ do - local _520_ = (_3flua_name or name) - local _521_ = zero_arity - local _522_ = unary_prefix - local function _524_(...) - return arithmetic_special(_520_, _521_, _522_, ...) + local _504_0 = (_3flua_name or name) + local function _506_(...) + return arithmetic_special(_504_0, zero_arity, unary_prefix, ...) end - _523_ = _524_ + _505_ = _506_ end - SPECIALS[name] = _523_ + SPECIALS[name] = _505_ return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.") end define_arithmetic_special("+", "0") @@ -1617,14 +1602,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local padded_native_name = (" " .. native_name .. " ") local prefixed_lib_name = ("bit." .. lib_name) for i = 2, len do - local subexprs - local _525_ + local subexprs = nil + local _507_ if (i ~= len) then - _525_ = 1 + _507_ = 1 else - _525_ = nil + _507_ = nil end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _525_}) + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _507_}) utils.map(subexprs, tostring, operands) end if (#operands == 1) then @@ -1643,18 +1628,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end local function define_bitop_special(name, zero_arity, unary_prefix, native) - local _535_ - do - local _531_ = native - local _532_ = name - local _533_ = zero_arity - local _534_ = unary_prefix - local function _536_(...) - return bitop_special(_531_, _532_, _533_, _534_, ...) - end - _535_ = _536_ + local function _513_(...) + return bitop_special(native, name, zero_arity, unary_prefix, ...) end - SPECIALS[name] = _535_ + SPECIALS[name] = _513_ return nil end define_bitop_special("lshift", nil, "1", "<<") @@ -1668,17 +1645,47 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("bor", {"x1", "x2", "..."}, "Bitwise OR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") doc_special("bxor", {"x1", "x2", "..."}, "Bitwise XOR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.") - local function native_comparator(op, _537_, scope, parent) - local _arg_538_ = _537_ - local _ = _arg_538_[1] - local lhs_ast = _arg_538_[2] - local rhs_ast = _arg_538_[3] - local _let_539_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) - local lhs = _let_539_[1] - local _let_540_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) - local rhs = _let_540_[1] + local function native_comparator(op, _514_0, scope, parent) + local _515_ = _514_0 + local _ = _515_[1] + local lhs_ast = _515_[2] + local rhs_ast = _515_[3] + local _516_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) + local lhs = _516_[1] + local _517_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) + local rhs = _517_[1] return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs)) end + local function idempotent_comparator(op, chain_op, ast, scope, parent) + local vals = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 2, #ast do + local val_19_ = tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + vals = tbl_17_ + end + local comparisons = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 1, (#vals - 1) do + local val_19_ = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + comparisons = tbl_17_ + end + local chain = string.format(" %s ", (chain_op or "and")) + return table.concat(comparisons, chain) + end local function double_eval_protected_comparator(op, chain_op, ast, scope, parent) local arglist = {} local comparisons = {} @@ -1686,10 +1693,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local chain = string.format(" %s ", (chain_op or "and")) for i = 2, #ast do table.insert(arglist, tostring(compiler.gensym(scope))) - table.insert(vals, tostring((compiler.compile1(ast[i], scope, parent, {nval = 1}))[1])) + table.insert(vals, tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1])) end - for i = 1, (#arglist - 1) do - table.insert(comparisons, string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)])) + do + local tbl_17_ = comparisons + local i_18_ = #tbl_17_ + for i = 1, (#arglist - 1) do + local val_19_ = string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end end return string.format("(function(%s) return %s end)(%s)", table.concat(arglist, ","), table.concat(comparisons, chain), table.concat(vals, ",")) end @@ -1700,6 +1715,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.assert((2 < #ast), "expected at least two arguments", ast) if (3 == #ast) then return native_comparator(op, ast, scope, parent) + elseif utils["every?"]({unpack(ast, 2)}, utils["idempotent-expr?"]) then + return idempotent_comparator(op, _3fchain_op, ast, scope, parent) else return double_eval_protected_comparator(op, _3fchain_op, ast, scope, parent) end @@ -1729,7 +1746,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") define_unary_special("length", "#") doc_special("length", {"x"}, "Returns the length of a table or string.") - do end (SPECIALS)["~="] = SPECIALS["not="] + SPECIALS["~="] = SPECIALS["not="] SPECIALS["#"] = SPECIALS.length SPECIALS.quote = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) @@ -1738,7 +1755,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct this_scope = this_scope.parent if (this_scope == compiler.scopes.compiler) then runtime = false - else end end return compiler["do-quote"](ast[2], scope, parent, runtime) @@ -1752,26 +1768,25 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local safe_require = nil local function safe_compiler_env() - local _544_ + local _524_ do - local _543_ = rawget(_G, "utf8") - if (nil ~= _543_) then - _544_ = utils.copy(_543_) + local _523_0 = rawget(_G, "utf8") + if (nil ~= _523_0) then + _524_ = utils.copy(_523_0) else - _544_ = _543_ + _524_ = _523_0 end end - return {table = utils.copy(table), math = utils.copy(math), string = utils.copy(string), pairs = utils.stablepairs, ipairs = ipairs, select = select, tostring = tostring, tonumber = tonumber, bit = rawget(_G, "bit"), pcall = pcall, xpcall = xpcall, next = next, print = print, type = type, assert = assert, error = error, setmetatable = setmetatable, getmetatable = safe_getmetatable, require = safe_require, rawlen = rawget(_G, "rawlen"), rawget = rawget, rawset = rawset, rawequal = rawequal, _VERSION = _VERSION, utf8 = _544_} + return {_VERSION = _VERSION, assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = utils.stablepairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, require = safe_require, select = select, setmetatable = setmetatable, string = utils.copy(string), table = utils.copy(table), tonumber = tonumber, tostring = tostring, type = type, utf8 = _524_, xpcall = xpcall} end local function combined_mt_pairs(env) local combined = {} - local _let_546_ = getmetatable(env) - local __index = _let_546_["__index"] + local _526_ = getmetatable(env) + local __index = _526_["__index"] if ("table" == type(__index)) then for k, v in pairs(__index) do combined[k] = v end - else end for k, v in next, env, nil do combined[k] = v @@ -1779,60 +1794,57 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return next, combined, nil end local function make_compiler_env(ast, scope, parent, _3fopts) - local provided + local provided = nil do - local _548_ = (_3fopts or utils.root.options) - if ((_G.type(_548_) == "table") and ((_548_)["compiler-env"] == "strict")) then + local _528_0 = (_3fopts or utils.root.options) + if ((_G.type(_528_0) == "table") and (_528_0["compiler-env"] == "strict")) then provided = safe_compiler_env() - elseif ((_G.type(_548_) == "table") and (nil ~= (_548_).compilerEnv)) then - local compilerEnv = (_548_).compilerEnv + elseif ((_G.type(_528_0) == "table") and (nil ~= _528_0.compilerEnv)) then + local compilerEnv = _528_0.compilerEnv provided = compilerEnv - elseif ((_G.type(_548_) == "table") and (nil ~= (_548_)["compiler-env"])) then - local compiler_env = (_548_)["compiler-env"] + elseif ((_G.type(_528_0) == "table") and (nil ~= _528_0["compiler-env"])) then + local compiler_env = _528_0["compiler-env"] provided = compiler_env - elseif true then - local _ = _548_ - provided = safe_compiler_env(false) else - provided = nil + local _ = _528_0 + provided = safe_compiler_env(false) end end - local env - local function _550_(base) - return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) - end - local function _551_() + local env = nil + local function _530_() return compiler.scopes.macro end - local function _552_(symbol) + local function _531_(symbol) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.scopes.macro.manglings[tostring(symbol)] end - local function _553_(form) + local function _532_(base) + return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) + end + local function _533_(form) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.macroexpand(form, compiler.scopes.macro) end - env = {_AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), ["macro-loaded"] = macro_loaded, unpack = unpack, ["assert-compile"] = compiler.assert, view = view, version = utils.version, metadata = compiler.metadata, ["ast-source"] = utils["ast-source"], list = utils.list, ["list?"] = utils["list?"], ["table?"] = utils["table?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], comment = utils.comment, ["comment?"] = utils["comment?"], ["varg?"] = utils["varg?"], gensym = _550_, ["get-scope"] = _551_, ["in-scope?"] = _552_, macroexpand = _553_} + env = {["assert-compile"] = compiler.assert, ["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["get-scope"] = _530_, ["in-scope?"] = _531_, ["list?"] = utils["list?"], ["macro-loaded"] = macro_loaded, ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), comment = utils.comment, gensym = _532_, list = utils.list, macroexpand = _533_, metadata = compiler.metadata, sequence = utils.sequence, sym = utils.sym, unpack = unpack, version = utils.version, view = view} env._G = env return setmetatable(env, {__index = provided, __newindex = provided, __pairs = combined_mt_pairs}) end - local function _555_(...) - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local function _534_(...) + local tbl_17_ = {} + local i_18_ = #tbl_17_ for c in string.gmatch((package.config or ""), "([^\n]+)") do - local val_16_auto = c - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = c + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_14_auto + return tbl_17_ end - local _local_554_ = _555_(...) - local dirsep = _local_554_[1] - local pathsep = _local_554_[2] - local pathmark = _local_554_[3] + local _536_ = _534_(...) + local dirsep = _536_[1] + local pathsep = _536_[2] + local pathmark = _536_[3] local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or ";"), pathsep = (pathsep or "?")} local function escapepat(str) return string.gsub(str, "[^%w]", "%%%1") @@ -1845,40 +1857,36 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function try_path(path) local filename = path:gsub(escapepat(pkg_config.pathmark), no_dot_module) local filename2 = path:gsub(escapepat(pkg_config.pathmark), modulename) - local _557_ = (io.open(filename) or io.open(filename2)) - if (nil ~= _557_) then - local file = _557_ + local _537_0 = (io.open(filename) or io.open(filename2)) + if (nil ~= _537_0) then + local file = _537_0 file:close() return filename - elseif true then - local _ = _557_ - return nil, ("no file '" .. filename .. "'") else - return nil + local _ = _537_0 + return nil, ("no file '" .. filename .. "'") end end local function find_in_path(start, _3ftried_paths) - local _559_ = fullpath:match(pattern, start) - if (nil ~= _559_) then - local path = _559_ - local _560_, _561_ = try_path(path) - if (nil ~= _560_) then - local filename = _560_ + local _539_0 = fullpath:match(pattern, start) + if (nil ~= _539_0) then + local path = _539_0 + local _540_0, _541_0 = try_path(path) + if (nil ~= _540_0) then + local filename = _540_0 return filename - elseif ((_560_ == nil) and (nil ~= _561_)) then - local error = _561_ - local function _563_() - local _562_ = (_3ftried_paths or {}) - table.insert(_562_, error) - return _562_ + elseif ((_540_0 == nil) and (nil ~= _541_0)) then + local error = _541_0 + local function _543_() + local _542_0 = (_3ftried_paths or {}) + table.insert(_542_0, error) + return _542_0 end - return find_in_path((start + #path + 1), _563_()) - else - return nil + return find_in_path((start + #path + 1), _543_()) end - elseif true then - local _ = _559_ - local function _565_() + else + local _ = _539_0 + local function _545_() local tried_paths = table.concat((_3ftried_paths or {}), "\n\9") if (_VERSION < "Lua 5.4") then return ("\n\9" .. tried_paths) @@ -1886,41 +1894,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return tried_paths end end - return nil, _565_() - else - return nil + return nil, _545_() end end return find_in_path(1) end local function make_searcher(_3foptions) - local function _568_(module_name) + local function _548_(module_name) local opts = utils.copy(utils.root.options) for k, v in pairs((_3foptions or {})) do opts[k] = v end opts["module-name"] = module_name - local _569_, _570_ = search_module(module_name) - if (nil ~= _569_) then - local filename = _569_ - local _573_ - do - local _571_ = filename - local _572_ = opts - local function _574_(...) - return utils["fennel-module"].dofile(_571_, _572_, ...) - end - _573_ = _574_ + local _549_0, _550_0 = search_module(module_name) + if (nil ~= _549_0) then + local filename = _549_0 + local function _551_(...) + return utils["fennel-module"].dofile(filename, opts, ...) end - return _573_, filename - elseif ((_569_ == nil) and (nil ~= _570_)) then - local error = _570_ + return _551_, filename + elseif ((_549_0 == nil) and (nil ~= _550_0)) then + local error = _550_0 return error - else - return nil end end - return _568_ + return _548_ end local function dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) local searchers = (package.loaders or package.searchers or {}) @@ -1930,116 +1928,101 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return m end local function fennel_macro_searcher(module_name) - local opts + local opts = nil do - local _576_ = utils.copy(utils.root.options) - do end (_576_)["module-name"] = module_name - _576_["env"] = "_COMPILER" - _576_["requireAsInclude"] = false - _576_["allowedGlobals"] = nil - opts = _576_ + local _553_0 = utils.copy(utils.root.options) + _553_0["module-name"] = module_name + _553_0["env"] = "_COMPILER" + _553_0["requireAsInclude"] = false + _553_0["allowedGlobals"] = nil + opts = _553_0 end - local _577_ = search_module(module_name, utils["fennel-module"]["macro-path"]) - if (nil ~= _577_) then - local filename = _577_ - local _578_ + local _554_0 = search_module(module_name, utils["fennel-module"]["macro-path"]) + if (nil ~= _554_0) then + local filename = _554_0 + local _555_ if (opts["compiler-env"] == _G) then - local _579_ = fennel_macro_searcher - local _580_ = filename - local _581_ = opts - local function _583_(...) - return dofile_with_searcher(_579_, _580_, _581_, ...) + local function _556_(...) + return dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) end - _578_ = _583_ + _555_ = _556_ else - local _584_ = filename - local _585_ = opts - local function _587_(...) - return utils["fennel-module"].dofile(_584_, _585_, ...) + local function _557_(...) + return utils["fennel-module"].dofile(filename, opts, ...) end - _578_ = _587_ + _555_ = _557_ end - return _578_, filename - else - return nil + return _555_, filename end end local function lua_macro_searcher(module_name) - local _590_ = search_module(module_name, package.path) - if (nil ~= _590_) then - local filename = _590_ - local code + local _560_0 = search_module(module_name, package.path) + if (nil ~= _560_0) then + local filename = _560_0 + local code = nil do local f = io.open(filename) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _592_() + local function _562_() return assert(f:read("*a")) end - code = close_handlers_8_auto(_G.xpcall(_592_, (package.loaded.fennel or debug).traceback)) + code = close_handlers_10_(_G.xpcall(_562_, (package.loaded.fennel or debug).traceback)) end local chunk = load_code(code, make_compiler_env(), filename) return chunk, filename - else - return nil end end local macro_searchers = {fennel_macro_searcher, lua_macro_searcher} local function search_macro_module(modname, n) - local _594_ = macro_searchers[n] - if (nil ~= _594_) then - local f = _594_ - local _595_, _596_ = f(modname) - if ((nil ~= _595_) and true) then - local loader = _595_ - local _3ffilename = _596_ + local _564_0 = macro_searchers[n] + if (nil ~= _564_0) then + local f = _564_0 + local _565_0, _566_0 = f(modname) + if ((nil ~= _565_0) and true) then + local loader = _565_0 + local _3ffilename = _566_0 return loader, _3ffilename - elseif true then - local _ = _595_ - return search_macro_module(modname, (n + 1)) else - return nil + local _ = _565_0 + return search_macro_module(modname, (n + 1)) end - else - return nil end end local function sandbox_fennel_module(modname) if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then return {metadata = compiler.metadata, view = view} - else - return nil end end - local function _600_(modname) - local function _601_() + local function _570_(modname) + local function _571_() local loader, filename = search_macro_module(modname, 1) compiler.assert(loader, (modname .. " module not found.")) - do end (macro_loaded)[modname] = loader(modname, filename) + macro_loaded[modname] = loader(modname, filename) return macro_loaded[modname] end - return (macro_loaded[modname] or sandbox_fennel_module(modname) or _601_()) + return (macro_loaded[modname] or sandbox_fennel_module(modname) or _571_()) end - safe_require = _600_ + safe_require = _570_ local function add_macros(macros_2a, ast, scope) compiler.assert(utils["table?"](macros_2a), "expected macros to be table", ast) for k, v in pairs(macros_2a) do compiler.assert((type(v) == "function"), "expected each macro to be function", ast) compiler["check-binding-valid"](utils.sym(k), scope, ast, {["macro?"] = true}) - do end (scope.macros)[k] = v + scope.macros[k] = v end return nil end - local function resolve_module_name(_602_, _scope, _parent, opts) - local _arg_603_ = _602_ - local filename = _arg_603_["filename"] - local second = _arg_603_[2] + local function resolve_module_name(_572_0, _scope, _parent, opts) + local _573_ = _572_0 + local second = _573_[2] + local filename = _573_["filename"] local filename0 = (filename or (utils["table?"](second) and second.filename)) local module_name = utils.root.options["module-name"] local modexpr = compiler.compile(second, opts) @@ -2053,8 +2036,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if not macro_loaded[modname] then local loader, filename = search_macro_module(modname, 1) compiler.assert(loader, (modname .. " module not found."), ast) - do end (macro_loaded)[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) - else + macro_loaded[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) end if ("import-macros" == tostring(ast[1])) then return macro_loaded[modname] @@ -2068,13 +2050,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local forms = {} if utils.root.options.requireAsInclude then subscope.specials.require = compiler["require-include"] - else end for _, val in parser.parser(parser["string-stream"](src), path) do table.insert(forms, val) end for i = 1, #forms do - local subopts + local subopts = nil if (i == #forms) then subopts = {tail = true} else @@ -2087,21 +2068,21 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local function include_path(ast, opts, path, mod, fennel_3f) utils.root.scope.includes[mod] = "fnl/loading" - local src + local src = nil do local f = assert(io.open(path)) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _609_() + local function _579_() return assert(f:read("*all")):gsub("[\13\n]*$", "") end - src = close_handlers_8_auto(_G.xpcall(_609_, (package.loaded.fennel or debug).traceback)) + src = close_handlers_10_(_G.xpcall(_579_, (package.loaded.fennel or debug).traceback)) end local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") local target = ("package.preload[%q]"):format(mod) @@ -2125,23 +2106,19 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (utils.root.scope.includes[mod] == "fnl/loading") then compiler.assert(fallback, "circular include detected", ast) return fallback(modexpr) - else - return nil end end SPECIALS.include = function(ast, scope, parent, opts) compiler.assert((#ast == 2), "expected one argument", ast) - local modexpr + local modexpr = nil do - local _612_, _613_ = pcall(resolve_module_name, ast, scope, parent, opts) - if ((_612_ == true) and (nil ~= _613_)) then - local modname = _613_ + local _582_0, _583_0 = pcall(resolve_module_name, ast, scope, parent, opts) + if ((_582_0 == true) and (nil ~= _583_0)) then + local modname = _583_0 modexpr = utils.expr(string.format("%q", modname), "literal") - elseif true then - local _ = _612_ - modexpr = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] else - modexpr = nil + local _ = _582_0 + modexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] end end if ((modexpr.type ~= "literal") or ((modexpr[1]):byte() ~= 34)) then @@ -2153,17 +2130,17 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct else local mod = load_code(("return " .. modexpr[1]))() local oldmod = utils.root.options["module-name"] - local _ + local _ = nil utils.root.options["module-name"] = mod _ = nil - local res - local function _617_() - local _616_ = search_module(mod) - if (nil ~= _616_) then - local fennel_path = _616_ + local res = nil + local function _587_() + local _586_0 = search_module(mod) + if (nil ~= _586_0) then + local fennel_path = _586_0 return include_path(ast, opts, fennel_path, mod, true) - elseif true then - local _0 = _616_ + else + local _0 = _586_0 local lua_path = search_module(mod, package.path) if lua_path then return include_path(ast, opts, lua_path, mod, false) @@ -2172,11 +2149,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct else return compiler.assert(false, ("module not found " .. mod), ast) end - else - return nil end end - res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _617_()) + res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _587_()) utils.root.options["module-name"] = oldmod return res end @@ -2187,10 +2162,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local opts = utils.copy(utils.root.options) opts.scope = compiler["make-scope"](compiler.scopes.compiler) opts.allowedGlobals = current_global_names(env) - return load_code(compiler.compile(ast, opts), wrap_env(env))(opts["module-name"], ast.filename) + return assert(load_code(compiler.compile(ast, opts), wrap_env(env)), opts["module-name"], ast.filename)() end SPECIALS.macros = function(ast, scope, parent) - compiler.assert((#ast == 2), "Expected one table argument", ast) + compiler.assert(((#ast == 2) and utils["table?"](ast[2])), "Expected one table argument", ast) return add_macros(eval_compiler_2a(ast[2], scope, parent), ast, scope, parent) end doc_special("macros", {"{:macro-name-1 (fn [...] ...) ... :macro-name-N macro-body-N}"}, "Define all functions in the given table as macros local to the current scope.") @@ -2198,11 +2173,11 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local old_first = ast[1] ast[1] = utils.sym("do") local val = eval_compiler_2a(ast, scope, parent) - do end (ast)[1] = old_first + ast[1] = old_first return val end doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.", true) - return {doc = doc_2a, ["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env, ["search-module"] = search_module, ["make-searcher"] = make_searcher, ["wrap-env"] = wrap_env} + return {["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env, ["make-searcher"] = make_searcher, ["search-module"] = search_module, ["wrap-env"] = wrap_env, doc = doc_2a} end package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or function(...) local utils = require("fennel.utils") @@ -2212,16 +2187,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local scopes = {} local function make_scope(_3fparent) local parent = (_3fparent or scopes.global) - local _258_ + local _252_ if parent then - _258_ = ((parent.depth or 0) + 1) + _252_ = ((parent.depth or 0) + 1) else - _258_ = 0 + _252_ = 0 end - return {includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), vararg = (parent and parent.vararg), depth = _258_, hashfn = (parent and parent.hashfn), refedglobals = {}, parent = parent} + return {autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), depth = _252_, gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), hashfn = (parent and parent.hashfn), includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), parent = parent, refedglobals = {}, specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), vararg = (parent and parent.vararg)} end local function assert_msg(ast, msg) - local ast_tbl + local ast_tbl = nil if ("table" == type(ast)) then ast_tbl = ast else @@ -2234,21 +2209,26 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local target = tostring((utils["sym?"](ast_tbl[1]) or ast_tbl[1] or "()")) return string.format("%s:%s:%s Compile error in '%s': %s", filename, line, col, target, msg) end - local function assert_compile(condition, msg, ast) + local function assert_compile(condition, msg, ast, _3ffallback_ast) if not condition then - local _let_261_ = (utils.root.options or {}) - local source = _let_261_["source"] - local unfriendly = _let_261_["unfriendly"] - if (nil == utils.hook("assert-compile", condition, msg, ast, utils.root.reset)) then + local _255_ = (utils.root.options or {}) + local error_pinpoint = _255_["error-pinpoint"] + local source = _255_["source"] + local unfriendly = _255_["unfriendly"] + local ast0 = nil + if next(utils["ast-source"](ast)) then + ast0 = ast + else + ast0 = (_3ffallback_ast or {}) + end + if (nil == utils.hook("assert-compile", condition, msg, ast0, utils.root.reset)) then utils.root.reset() if (unfriendly or not friend or not _G.io or not _G.io.read) then - error(assert_msg(ast, msg), 0) + error(assert_msg(ast0, msg), 0) else - friend["assert-compile"](condition, msg, ast, source) + friend["assert-compile"](condition, msg, ast0, source, {["error-pinpoint"] = error_pinpoint}) end - else end - else end return condition end @@ -2256,38 +2236,36 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct scopes.global.vararg = true scopes.compiler = make_scope(scopes.global) scopes.macro = scopes.global - local serialize_subst = {["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n", ["\11"] = "\\v", ["\12"] = "\\f"} + local serialize_subst = {["\11"] = "\\v", ["\12"] = "\\f", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n"} local function serialize_string(str) - local function _265_(_241) + local function _260_(_241) return ("\\" .. _241:byte()) end - return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _265_) + return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _260_) end local function global_mangling(str) if utils["valid-lua-identifier?"](str) then return str else - local function _266_(_241) + local function _261_(_241) return string.format("_%02x", _241:byte()) end - return ("__fnl_global__" .. str:gsub("[^%w]", _266_)) + return ("__fnl_global__" .. str:gsub("[^%w]", _261_)) end end local function global_unmangling(identifier) - local _268_ = string.match(identifier, "^__fnl_global__(.*)$") - if (nil ~= _268_) then - local rest = _268_ - local _269_ - local function _270_(_241) + local _263_0 = string.match(identifier, "^__fnl_global__(.*)$") + if (nil ~= _263_0) then + local rest = _263_0 + local _264_0 = nil + local function _265_(_241) return string.char(tonumber(_241:sub(2), 16)) end - _269_ = string.gsub(rest, "_[%da-f][%da-f]", _270_) - return _269_ - elseif true then - local _ = _268_ - return identifier + _264_0 = string.gsub(rest, "_[%da-f][%da-f]", _265_) + return _264_0 else - return nil + local _ = _263_0 + return identifier end end local allowed_globals = nil @@ -2303,29 +2281,29 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function local_mangling(str, scope, ast, _3ftemp_manglings) assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast) - local raw - if ((utils["lua-keywords"])[str] or str:match("^%d")) then + local raw = nil + if (utils["lua-keywords"][str] or str:match("^%d")) then raw = ("_" .. str) else raw = str end - local mangling - local function _274_(_241) + local mangling = nil + local function _269_(_241) return string.format("_%02x", _241:byte()) end - mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _274_) + mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _269_) local unique = unique_mangling(mangling, mangling, scope, 0) - do end (scope.unmanglings)[unique] = str + scope.unmanglings[unique] = str do local manglings = (_3ftemp_manglings or scope.manglings) - do end (manglings)[str] = unique + manglings[str] = unique end return unique end local function apply_manglings(scope, new_manglings, ast) for raw, mangled in pairs(new_manglings) do assert_compile(not scope.refedglobals[mangled], ("use of global " .. raw .. " is aliased by a local"), ast) - do end (scope.manglings)[raw] = mangled + scope.manglings[raw] = mangled end return nil end @@ -2354,7 +2332,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or "")) end scope.unmanglings[mangling] = (_3fbase or true) - do end (scope.gensyms)[mangling] = true + scope.gensyms[mangling] = true return mangling end local function combine_auto_gensym(parts, first) @@ -2366,35 +2344,32 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return table.concat(parts, ".") end local function autogensym(base, scope) - local _277_ = utils["multi-sym?"](base) - if (nil ~= _277_) then - local parts = _277_ + local _272_0 = utils["multi-sym?"](base) + if (nil ~= _272_0) then + local parts = _272_0 return combine_auto_gensym(parts, autogensym(parts[1], scope)) - elseif true then - local _ = _277_ - local function _278_() + else + local _ = _272_0 + local function _273_() local mangling = gensym(scope, base:sub(1, ( - 2)), "auto") - do end (scope.autogensyms)[base] = mangling + scope.autogensyms[base] = mangling return mangling end - return (scope.autogensyms[base] or _278_()) - else - return nil + return (scope.autogensyms[base] or _273_()) end end local function check_binding_valid(symbol, scope, ast, _3fopts) local name = tostring(symbol) - local macro_3f + local macro_3f = nil do - local t_280_ = _3fopts - if (nil ~= t_280_) then - t_280_ = (t_280_)["macro?"] - else + local _275_0 = _3fopts + if (nil ~= _275_0) then + _275_0 = _275_0["macro?"] end - macro_3f = t_280_ + macro_3f = _275_0 end - assert_compile(not name:find("&"), "invalid character: &") - assert_compile(not name:find("^%."), "invalid character: .") + assert_compile(not name:find("&"), "invalid character: &", symbol) + assert_compile(not name:find("^%."), "invalid character: .", symbol) assert_compile(not (scope.specials[name] or (not macro_3f and scope.macros[name])), ("local %s was overshadowed by a special form or macro"):format(name), ast) return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol) end @@ -2402,7 +2377,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct check_binding_valid(symbol, scope, ast) local name = tostring(symbol) assert_compile(not utils["multi-sym?"](name), ("unexpected multi symbol " .. name), ast) - do end (scope.symmeta)[name] = meta + scope.symmeta[name] = meta return local_mangling(name, scope, ast, _3ftemp_manglings) end local function hashfn_arg_name(name, multi_sym_parts, scope) @@ -2413,11 +2388,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif multi_sym_parts then if (multi_sym_parts and (multi_sym_parts[1] == "$")) then multi_sym_parts[1] = "$1" - else end return table.concat(multi_sym_parts, ".") - else - return nil end end local function symbol_to_expression(symbol, scope, _3freference_3f) @@ -2430,14 +2402,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local local_3f = scope.manglings[parts[1]] if (local_3f and scope.symmeta[parts[1]]) then scope.symmeta[parts[1]]["used"] = true - else end - assert_compile(not scope.macros[parts[1]], "tried to reference a macro at runtime", symbol) - assert_compile((not scope.specials[parts[1]] or ("require" == parts[1])), "tried to reference a special form at runtime", symbol) - assert_compile((not _3freference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown identifier in strict mode: " .. tostring(parts[1])), symbol) + assert_compile(not scope.macros[parts[1]], "tried to reference a macro without calling it", symbol) + assert_compile((not scope.specials[parts[1]] or ("require" == parts[1])), "tried to reference a special form without calling it", symbol) + assert_compile((not _3freference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown identifier: " .. tostring(parts[1])), symbol) if (allowed_globals and not local_3f and scope.parent) then scope.parent.refedglobals[parts[1]] = true - else end return utils.expr(combine_parts(parts, scope), etype) end @@ -2476,10 +2446,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local source = utils["ast-source"](subchunk.ast) if (file == source.filename) then last_line0 = math.max(last_line0, (source.line or 0)) - else end last_line0 = flatten(subchunk, out, last_line0, file) - else end end end @@ -2490,32 +2458,31 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for i = 1, last do if (out[i] == nil) then out[i] = "" - else end end return table.concat(out, "\n") end local function flatten_chunk(file_sourcemap, chunk, tab, depth) if chunk.leaf then - local _let_292_ = utils["ast-source"](chunk.ast) - local filename = _let_292_["filename"] - local line = _let_292_["line"] + local _287_ = utils["ast-source"](chunk.ast) + local filename = _287_["filename"] + local line = _287_["line"] table.insert(file_sourcemap, {filename, line}) return chunk.leaf else - local tab0 + local tab0 = nil do - local _293_ = tab - if (_293_ == true) then + local _288_0 = tab + if (_288_0 == true) then tab0 = " " - elseif (_293_ == false) then + elseif (_288_0 == false) then tab0 = "" - elseif (_293_ == tab) then + elseif (_288_0 == tab) then tab0 = tab - elseif (_293_ == nil) then + elseif (_288_0 == nil) then tab0 = "" else - tab0 = nil + tab0 = nil end end local function parter(c) @@ -2526,8 +2493,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else return sub end - else - return nil end end return table.concat(utils.map(chunk, parter), "\n") @@ -2560,24 +2525,21 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function make_metadata() - local function _301_(self, tgt, key) + local function _296_(self, tgt, key) if self[tgt] then return self[tgt][key] - else - return nil end end - local function _303_(self, tgt, key, value) + local function _298_(self, tgt, key, value) self[tgt] = (self[tgt] or {}) - do end (self[tgt])[key] = value + self[tgt][key] = value return tgt end - local function _304_(self, tgt, ...) + local function _299_(self, tgt, ...) local kv_len = select("#", ...) local kvs = {...} if ((kv_len % 2) ~= 0) then error("metadata:setall() expected even number of k/v pairs") - else end self[tgt] = (self[tgt] or {}) for i = 1, kv_len, 2 do @@ -2585,7 +2547,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return tgt end - return setmetatable({}, {__index = {get = _301_, set = _303_, setall = _304_}, __mode = "k"}) + return setmetatable({}, {__index = {get = _296_, set = _298_, setall = _299_}, __mode = "k"}) end local function exprs1(exprs) return table.concat(utils.map(exprs, tostring), ", ") @@ -2598,14 +2560,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) elseif (se.type == "statement") then local code = tostring(se) - local disambiguated + local disambiguated = nil if (code:byte() == 40) then disambiguated = ("do end " .. code) else disambiguated = code end emit(chunk, disambiguated, ast) - else end end return nil @@ -2625,47 +2586,42 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct exprs[i] = utils.expr("nil", "literal") end end - else end - else end if opts.tail then emit(parent, string.format("return %s", exprs1(exprs)), ast) - else end if opts.target then local result = exprs1(exprs) - local function _312_() + local function _307_() if (result == "") then return "nil" else return result end end - emit(parent, string.format("%s = %s", opts.target, _312_()), ast) - else + emit(parent, string.format("%s = %s", opts.target, _307_()), ast) end if (opts.tail or opts.target) then return {returned = true} else - local _314_ = exprs - _314_["returned"] = true - return _314_ + exprs["returned"] = true + return exprs end end local function find_macro(ast, scope) - local macro_2a + local macro_2a = nil do - local _316_ = utils["sym?"](ast[1]) - if (_316_ ~= nil) then - local _317_ = tostring(_316_) - if (_317_ ~= nil) then - macro_2a = scope.macros[_317_] + local _310_0 = utils["sym?"](ast[1]) + if (_310_0 ~= nil) then + local _311_0 = tostring(_310_0) + if (_311_0 ~= nil) then + macro_2a = scope.macros[_311_0] else - macro_2a = _317_ + macro_2a = _311_0 end else - macro_2a = _316_ + macro_2a = _310_0 end end local multi_sym_parts = utils["multi-sym?"](ast[1]) @@ -2677,50 +2633,37 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return macro_2a end end - local function propagate_trace_info(_321_, _index, node) - local _arg_322_ = _321_ - local filename = _arg_322_["filename"] - local line = _arg_322_["line"] - local bytestart = _arg_322_["bytestart"] - local byteend = _arg_322_["byteend"] + local function propagate_trace_info(_315_0, _index, node) + local _316_ = _315_0 + local byteend = _316_["byteend"] + local bytestart = _316_["bytestart"] + local filename = _316_["filename"] + local line = _316_["line"] do local src = utils["ast-source"](node) if (("table" == type(node)) and (filename ~= src.filename)) then src.filename, src.line, src["from-macro?"] = filename, line, true src.bytestart, src.byteend = bytestart, byteend - else end end return ("table" == type(node)) end - local function max_n(t) - local n = 0 - for k in pairs(t) do - if ("number" == type(k)) then - n = math.max(k, n) - else - end - end - return n - end local function quote_literal_nils(index, node, parent) if (parent and utils["list?"](parent)) then - for i = 1, max_n(parent) do - local _325_ = parent[i] - if (_325_ == nil) then + for i = 1, utils.maxn(parent) do + local _318_0 = parent[i] + if (_318_0 == nil) then parent[i] = utils.sym("nil") - else end end - else end return index, node, parent end local function comp(f, g) - local function _328_(...) + local function _321_(...) return f(g(...)) end - return _328_ + return _321_ end local function built_in_3f(m) local found_3f = false @@ -2731,41 +2674,36 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return found_3f end local function macroexpand_2a(ast, scope, _3fonce) - local _329_ + local _322_0 = nil if utils["list?"](ast) then - _329_ = find_macro(ast, scope) + _322_0 = find_macro(ast, scope) else - _329_ = nil + _322_0 = nil end - if (_329_ == false) then + if (_322_0 == false) then return ast - elseif (nil ~= _329_) then - local macro_2a = _329_ + elseif (nil ~= _322_0) then + local macro_2a = _322_0 local old_scope = scopes.macro - local _ + local _ = nil scopes.macro = scope _ = nil local ok, transformed = nil, nil - local function _331_() + local function _324_() return macro_2a(unpack(ast, 2)) end - local function _332_() + local function _325_() if built_in_3f(macro_2a) then return tostring else return debug.traceback end end - ok, transformed = xpcall(_331_, _332_()) - local _334_ - do - local _333_ = ast - local function _335_(...) - return propagate_trace_info(_333_, ...) - end - _334_ = _335_ + ok, transformed = xpcall(_324_, _325_()) + local function _326_(...) + return propagate_trace_info(ast, ...) end - utils["walk-tree"](transformed, comp(_334_, quote_literal_nils)) + utils["walk-tree"](transformed, comp(_326_, quote_literal_nils)) scopes.macro = old_scope assert_compile(ok, transformed, ast) if (_3fonce or not transformed) then @@ -2773,22 +2711,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else return macroexpand_2a(transformed, scope) end - elseif true then - local _ = _329_ - return ast else - return nil + local _ = _322_0 + return ast end end local function compile_special(ast, scope, parent, opts, special) local exprs = (special(ast, scope, parent, opts) or utils.expr("nil", "literal")) - local exprs0 + local exprs0 = nil if ("table" ~= type(exprs)) then exprs0 = utils.expr(exprs, "expression") else exprs0 = exprs end - local exprs2 + local exprs2 = nil if utils["expr?"](exprs0) then exprs2 = {exprs0} else @@ -2804,17 +2740,17 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function compile_function_call(ast, scope, parent, opts, compile1, len) local fargs = {} - local fcallee = (compile1(ast[1], scope, parent, {nval = 1}))[1] + local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1] assert_compile((utils["sym?"](ast[1]) or utils["list?"](ast[1]) or ("string" == type(ast[1]))), ("cannot call literal value " .. tostring(ast[1])), ast) for i = 2, len do - local subexprs - local _341_ + local subexprs = nil + local _332_ if (i ~= len) then - _341_ = 1 + _332_ = 1 else - _341_ = nil + _332_ = nil end - subexprs = compile1(ast[i], scope, parent, {nval = _341_}) + subexprs = compile1(ast[i], scope, parent, {nval = _332_}) table.insert(fargs, subexprs[1]) if (i == len) then for j = 2, #subexprs do @@ -2824,7 +2760,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct keep_side_effects(subexprs, parent, 2, ast[i]) end end - local pat + local pat = nil if ("string" == type(ast[1])) then pat = "(%s)(%s)" else @@ -2852,19 +2788,19 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function compile_varg(ast, scope, parent, opts) - local _346_ + local _337_ if scope.hashfn then - _346_ = "use $... in hashfn" + _337_ = "use $... in hashfn" else - _346_ = "unexpected vararg" + _337_ = "unexpected vararg" end - assert_compile(scope.vararg, _346_, ast) + assert_compile(scope.vararg, _337_, ast) return handle_compile_opts({utils.expr("...", "varg")}, parent, opts, ast) end local function compile_sym(ast, scope, parent, opts) local multi_sym_parts = utils["multi-sym?"](ast) assert_compile(not (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]), "multisym method calls may only be in call position", ast) - local e + local e = nil if (ast[1] == "nil") then e = utils.expr("nil", "literal") else @@ -2873,71 +2809,73 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return handle_compile_opts({e}, parent, opts, ast) end local function serialize_number(n) - local _349_ = string.gsub(tostring(n), ",", ".") - return _349_ + local _340_0 = string.gsub(tostring(n), ",", ".") + return _340_0 end local function compile_scalar(ast, _scope, parent, opts) - local serialize + local serialize = nil do - local _350_ = type(ast) - if (_350_ == "nil") then + local _341_0 = type(ast) + if (_341_0 == "nil") then serialize = tostring - elseif (_350_ == "boolean") then + elseif (_341_0 == "boolean") then serialize = tostring - elseif (_350_ == "string") then + elseif (_341_0 == "string") then serialize = serialize_string - elseif (_350_ == "number") then + elseif (_341_0 == "number") then serialize = serialize_number else - serialize = nil + serialize = nil end end return handle_compile_opts({utils.expr(serialize(ast), "literal")}, parent, opts) end local function compile_table(ast, scope, parent, opts, compile1) - local buffer = {} - local function write_other_values(k) - if ((type(k) ~= "number") or (math.floor(k) ~= k) or (k < 1) or (#ast < k)) then - if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then - return {k, k} - else - local _let_352_ = compile1(k, scope, parent, {nval = 1}) - local compiled = _let_352_[1] - local kstr = ("[" .. tostring(compiled) .. "]") - return {kstr, k} - end + local function escape_key(k) + if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then + return k else - return nil + local _343_ = compile1(k, scope, parent, {nval = 1}) + local compiled = _343_[1] + return ("[" .. tostring(compiled) .. "]") end end + local keys = {} + local buffer = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i, elem in ipairs(ast) do + local val_19_ = nil + do + local nval = ((nil ~= ast[(i + 1)]) and 1) + keys[i] = true + val_19_ = exprs1(compile1(elem, scope, parent, {nval = nval})) + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + buffer = tbl_17_ + end do - local keys - do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for k, v in utils.stablepairs(ast) do - local val_16_auto = write_other_values(k, v) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else - end + local tbl_17_ = buffer + local i_18_ = #tbl_17_ + for k, v in utils.stablepairs(ast) do + local val_19_ = nil + if not keys[k] then + local _346_ = compile1(ast[k], scope, parent, {nval = 1}) + local v0 = _346_[1] + val_19_ = string.format("%s = %s", escape_key(k), tostring(v0)) + else + val_19_ = nil + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end - keys = tbl_14_auto end - local function _358_(_356_) - local _arg_357_ = _356_ - local k1 = _arg_357_[1] - local k2 = _arg_357_[2] - local _let_359_ = compile1(ast[k2], scope, parent, {nval = 1}) - local v = _let_359_[1] - return string.format("%s = %s", k1, tostring(v)) - end - utils.map(keys, _358_, buffer) - end - for i = 1, #ast do - local nval = ((i ~= #ast) and 1) - table.insert(buffer, exprs1(compile1(ast[i], scope, parent, {nval = nval}))) end return handle_compile_opts({utils.expr(("{" .. table.concat(buffer, ", ") .. "}"), "expression")}, parent, opts, ast) end @@ -2960,14 +2898,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function destructure(to, from, ast, scope, parent, opts) local opts0 = (opts or {}) - local _let_361_ = opts0 - local isvar = _let_361_["isvar"] - local declaration = _let_361_["declaration"] - local forceglobal = _let_361_["forceglobal"] - local forceset = _let_361_["forceset"] - local symtype = _let_361_["symtype"] + local _350_ = opts0 + local declaration = _350_["declaration"] + local forceglobal = _350_["forceglobal"] + local forceset = _350_["forceset"] + local isvar = _350_["isvar"] + local symtype = _350_["symtype"] local symtype0 = ("_" .. (symtype or "dst")) - local setter + local setter = nil if declaration then setter = "local %s = %s" else @@ -2986,32 +2924,29 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if ((#parts == 1) and not forceset) then assert_compile(not (forceglobal and meta), string.format("global %s conflicts with local", tostring(symbol)), symbol) assert_compile(not (meta and not meta.var), ("expected var " .. raw), symbol) - assert_compile((meta or not opts0.noundef), ("expected local " .. parts[1]), symbol) - else end + assert_compile((meta or not opts0.noundef or global_allowed_3f(parts[1])), ("expected local " .. parts[1]), symbol) if forceglobal then assert_compile(not scope.symmeta[scope.unmanglings[raw]], ("global " .. raw .. " conflicts with local"), symbol) - do end (scope.manglings)[raw] = global_mangling(raw) - do end (scope.unmanglings)[global_mangling(raw)] = raw + scope.manglings[raw] = global_mangling(raw) + scope.unmanglings[global_mangling(raw)] = raw if allowed_globals then table.insert(allowed_globals, raw) - else end - else end return symbol_to_expression(symbol, scope)[1] end end local function compile_top_target(lvalues) - local inits - local function _367_(_241) + local inits = nil + local function _356_(_241) if scope.manglings[_241] then return _241 else return "nil" end end - inits = utils.map(lvalues, _367_) + inits = utils.map(lvalues, _356_) local init = table.concat(inits, ", ") local lvalue = table.concat(lvalues, ", ") local plast = parent[#parent] @@ -3021,7 +2956,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for pi = plen, #parent do if (parent[pi] == plast) then plen = pi - else end end if ((#parent == (plen + 1)) and parent[#parent].leaf) then @@ -3031,7 +2965,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue .. " = " .. init)}) end - else end return ret end @@ -3046,28 +2979,25 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if declaration then scope.symmeta[tostring(left)] = {var = isvar} return nil - else - return nil end end local unpack_fn = "function (t, k, e)\n local mt = getmetatable(t)\n if 'table' == type(mt) and mt.__fennelrest then\n return mt.__fennelrest(t, k)\n elseif e then\n local rest = {}\n for k, v in pairs(t) do\n if not e[k] then rest[k] = v end\n end\n return rest\n else\n return {(table.unpack or unpack)(t, k)}\n end\n end" local function destructure_kv_rest(s, v, left, excluded_keys, destructure1) - local exclude_str - local _374_ + local exclude_str = nil + local _363_ do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, k in ipairs(excluded_keys) do - local val_16_auto = string.format("[%s] = true", serialize_string(k)) - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = string.format("[%s] = true", serialize_string(k)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _374_ = tbl_14_auto + _363_ = tbl_17_ end - exclude_str = table.concat(_374_, ", ") + exclude_str = table.concat(_363_, ", ") local subexpr = utils.expr(string.format(string.gsub(("(" .. unpack_fn .. ")(%s, %s, {%s})"), "\n%s*", " "), s, tostring(v), exclude_str), "expression") return destructure1(v, {subexpr}, left) end @@ -3080,21 +3010,21 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function destructure_table(left, rightexprs, top_3f, destructure1) local s = gensym(scope, symtype0) - local right + local right = nil do - local _376_ + local _365_0 = nil if top_3f then - _376_ = exprs1(compile1(from, scope, parent)) + _365_0 = exprs1(compile1(from, scope, parent)) else - _376_ = exprs1(rightexprs) + _365_0 = exprs1(rightexprs) end - if (_376_ == "") then + if (_365_0 == "") then right = "nil" - elseif (nil ~= _376_) then - local right0 = _376_ + elseif (nil ~= _365_0) then + local right0 = _365_0 right = right0 else - right = nil + right = nil end end local excluded_keys = {} @@ -3112,7 +3042,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct assert_compile((nil == trailing), "expected &as argument before last parameter", left) destructure_sym(next_sym, {utils.expr(tostring(s))}, left) else - local key + local key = nil if (type(k) == "string") then key = serialize_string(k) else @@ -3121,11 +3051,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression") if (type(k) == "string") then table.insert(excluded_keys, k) - else end destructure1(v, {subexpr}, left) end - else end end return nil @@ -3138,7 +3066,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else local symname = gensym(scope, symtype0) table.insert(left_names, symname) - do end (tables)[i] = {name, utils.expr(symname, "sym")} + tables[i] = {name, utils.expr(symname, "sym")} end end assert_compile(left[1], "must provide at least one value", left) @@ -3148,10 +3076,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for _, sym in ipairs(left) do if utils["sym?"](sym) then scope.symmeta[tostring(sym)] = {var = isvar} - else end end - else end for _, pair in utils.stablepairs(tables) do destructure1(pair[1], {pair[2]}, left) @@ -3166,12 +3092,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif utils["list?"](left) then destructure_values(left, up1, top_3f, destructure1) else - assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type((up1)[2]) == "table") and (up1)[2]) or up1)) + assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1)) end if top_3f then return {returned = true} - else - return nil end end local ret = destructure1(to, nil, ast, true) @@ -3183,7 +3107,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct opts.fallback = function(e, no_warn) if (not no_warn and ("literal" == e.type)) then utils.warn(("include module not found, falling back to require: %s"):format(tostring(e))) - else end return utils.expr(string.format("require(%s)", tostring(e)), "statement") end @@ -3195,15 +3118,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local scope = (opts.scope or make_scope(scopes.global)) local vals = {} local chunk = {} - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") + local _378_ = utils.root + _378_["set-reset"](_378_) allowed_globals = opts.allowedGlobals if (opts.indent == nil) then opts.indent = " " - else end if opts.requireAsInclude then scope.specials.require = require_include - else end utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts for _, val in parser.parser(strm, opts.filename, opts) do @@ -3214,30 +3136,29 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct keep_side_effects(exprs, chunk, nil, vals[i]) if (i == #vals) then utils.hook("chunk", vals[i], scope) - else end end allowed_globals = old_globals utils.root.reset() return flatten(chunk, opts) end - local function compile_string(str, opts) - return compile_stream(parser["string-stream"](str), (opts or {})) + local function compile_string(str, _3fopts) + local opts = (_3fopts or {}) + return compile_stream(parser["string-stream"](str, opts), opts) end local function compile(ast, opts) local opts0 = utils.copy(opts) local old_globals = allowed_globals local chunk = {} local scope = (opts0.scope or make_scope(scopes.global)) - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") + local _382_ = utils.root + _382_["set-reset"](_382_) allowed_globals = opts0.allowedGlobals if (opts0.indent == nil) then opts0.indent = " " - else end if opts0.requireAsInclude then scope.specials.require = require_include - else end utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts0 local exprs = compile1(ast, scope, chunk, {tail = true}) @@ -3261,17 +3182,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct info.short_src = remap.short_src end info.currentline = (remap[info.currentline][2] or -1) - else end if (info.what == "Lua") then - local function _396_() + local function _387_() if info.name then return ("'" .. info.name .. "'") else return "?" end end - return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _396_()) + return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _387_()) elseif (info.short_src == "(tail call)") then return " (tail call)" else @@ -3281,11 +3201,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function traceback(_3fmsg, _3fstart) local msg = tostring((_3fmsg or "")) - if ((msg:find("^Compile error") or msg:find("^Parse error")) and not utils["debug-on?"]("trace")) then + if ((msg:find("^%g+:%d+:%d+ Compile error:.*") or msg:find("^%g+:%d+:%d+ Parse error:.*")) and not utils["debug-on?"]("trace")) then return msg else local lines = {} - if (msg:find(":%d+: Compile error") or msg:find(":%d+: Parse error")) then + if (msg:find("^%g+:%d+:%d+ Compile error:") or msg:find("^%g+:%d+:%d+ Parse error:")) then table.insert(lines, msg) else local newmsg = msg:gsub("^[^:]*:%d+:%s+", "runtime error: ") @@ -3295,13 +3215,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local done_3f, level = false, (_3fstart or 2) while not done_3f do do - local _400_ = debug.getinfo(level, "Sln") - if (_400_ == nil) then + local _391_0 = debug.getinfo(level, "Sln") + if (_391_0 == nil) then done_3f = true - elseif (nil ~= _400_) then - local info = _400_ + elseif (nil ~= _391_0) then + local info = _391_0 table.insert(lines, traceback_frame(info)) - else end end level = (level + 1) @@ -3310,14 +3229,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function entry_transform(fk, fv) - local function _403_(k, v) + local function _394_(k, v) if (type(k) == "number") then return k, fv(v) else return fk(k), fv(v) end end - return _403_ + return _394_ end local function mixed_concat(t, joiner) local seen = {} @@ -3331,7 +3250,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if not seen[k] then ret = (ret .. s .. "[" .. k .. "]" .. "=" .. v) s = joiner - else end end return ret @@ -3344,7 +3262,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct assert_compile(not runtime_3f, "quoted ... may only be used at compile time", form) return "_VARARG" elseif utils["sym?"](form) then - local filename + local filename = nil if form.filename then filename = string.format("%q", form.filename) else @@ -3362,12 +3280,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local res = unpack(compile1(payload, scope, parent)) return res[1] elseif utils["list?"](form) then - local mapped - local function _408_() + local mapped = nil + local function _399_() return nil end - mapped = utils.kvmap(form, entry_transform(_408_, q)) - local filename + mapped = utils.kvmap(form, entry_transform(_399_, q)) + local filename = nil if form.filename then filename = string.format("%q", form.filename) else @@ -3378,67 +3296,70 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif utils["sequence?"](form) then local mapped = utils.kvmap(form, entry_transform(q, q)) local source = getmetatable(form) - local filename + local filename = nil if source.filename then filename = string.format("%q", source.filename) else filename = "nil" end - local _411_ + local _402_ if source then - _411_ = source.line + _402_ = source.line else - _411_ = "nil" + _402_ = "nil" end - return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _411_, "(getmetatable(sequence()))['sequence']") + return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _402_, "(getmetatable(sequence()))['sequence']") elseif (type(form) == "table") then local mapped = utils.kvmap(form, entry_transform(q, q)) local source = getmetatable(form) - local filename + local filename = nil if source.filename then filename = string.format("%q", source.filename) else filename = "nil" end - local function _414_() + local function _405_() if source then return source.line else return "nil" end end - return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _414_()) + return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _405_()) elseif (type(form) == "string") then return serialize_string(form) else return tostring(form) end end - return {compile = compile, compile1 = compile1, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["check-binding-valid"] = check_binding_valid, emit = emit, destructure = destructure, ["require-include"] = require_include, autogensym = autogensym, gensym = gensym, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["apply-manglings"] = apply_manglings, macroexpand = macroexpand_2a, ["declare-local"] = declare_local, ["make-scope"] = make_scope, ["keep-side-effects"] = keep_side_effects, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, scopes = scopes, traceback = traceback, metadata = make_metadata(), sourcemap = sourcemap} + return {["apply-manglings"] = apply_manglings, ["check-binding-valid"] = check_binding_valid, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["declare-local"] = declare_local, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["keep-side-effects"] = keep_side_effects, ["make-scope"] = make_scope, ["require-include"] = require_include, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, autogensym = autogensym, compile = compile, compile1 = compile1, destructure = destructure, emit = emit, gensym = gensym, macroexpand = macroexpand_2a, metadata = make_metadata(), scopes = scopes, sourcemap = sourcemap, traceback = traceback} end package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...) local utils = require("fennel.utils") local utf8_ok_3f, utf8 = pcall(require, "utf8") - local suggestions = {["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["unknown identifier in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["tried to reference a macro at runtime"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form at runtime"] = {"wrapping the special in a function if you need it to be first class"}, ["missing subject"] = {"adding an item to operate on"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}} + local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name", "making sure to use prefix operators, not infix"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["missing subject"] = {"adding an item to operate on"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["tried to reference a macro without calling it"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form without calling it"] = {"making sure to use prefix operators, not infix", "wrapping the special in a function if you need it to be first class"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown identifier: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} local unpack = (table.unpack or _G.unpack) local function suggest(msg) - local suggestion = nil + local s = nil for pat, sug in pairs(suggestions) do + if s then break end local matches = {msg:match(pat)} if (0 < #matches) then - if ("table" == type(sug)) then - local out = {} - for _, s in ipairs(sug) do - table.insert(out, s:format(unpack(matches))) + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, s0 in ipairs(sug) do + local val_19_ = s0:format(unpack(matches)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end - suggestion = out - else - suggestion = sug(matches) end + s = tbl_17_ else + s = nil end end - return suggestion + return s end local function read_line(filename, line, _3fsource) if _3fsource then @@ -3449,9 +3370,9 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( return matcher() else local f = assert(io.open(filename)) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) @@ -3463,11 +3384,11 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( end return f:read() end - return close_handlers_8_auto(_G.xpcall(_178_, (package.loaded.fennel or debug).traceback)) + return close_handlers_10_(_G.xpcall(_178_, (package.loaded.fennel or debug).traceback)) end end local function sub(str, start, _end) - if (_end < start) then + if ((_end < start) or (#str < start) or (#str < _end)) then return "" elseif utf8_ok_3f then return string.sub(str, utf8.offset(str, start), ((utf8.offset(str, (_end + 1)) or (utf8.len(str) + 1)) - 1)) @@ -3475,50 +3396,57 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( return string.sub(str, start, math.min(_end, str:len())) end end - local function highlight_line(codeline, col, _3fendcol) - local endcol = (_3fendcol or col) - local eol - if utf8_ok_3f then - eol = utf8.len(codeline) + local function highlight_line(codeline, col, _3fendcol, opts) + if ((opts and (false == opts["error-pinpoint"])) or (os and os.getenv and os.getenv("NO_COLOR"))) then + return codeline else - eol = string.len(codeline) + local _181_ = (opts or {}) + local error_pinpoint = _181_["error-pinpoint"] + local endcol = (_3fendcol or col) + local eol = nil + if utf8_ok_3f then + eol = utf8.len(codeline) + else + eol = string.len(codeline) + end + local _183_ = (error_pinpoint or {"\27[7m", "\27[0m"}) + local open = _183_[1] + local close = _183_[2] + return (sub(codeline, 1, col) .. open .. sub(codeline, (col + 1), (endcol + 1)) .. close .. sub(codeline, (endcol + 2), eol)) end - return (sub(codeline, 1, col) .. "\27[7m" .. sub(codeline, (col + 1), (endcol + 1)) .. "\27[0m" .. sub(codeline, (endcol + 2), eol)) end - local function friendly_msg(msg, _182_, source) - local _arg_183_ = _182_ - local filename = _arg_183_["filename"] - local line = _arg_183_["line"] - local col = _arg_183_["col"] - local endcol = _arg_183_["endcol"] + local function friendly_msg(msg, _185_0, source, opts) + local _186_ = _185_0 + local col = _186_["col"] + local endcol = _186_["endcol"] + local filename = _186_["filename"] + local line = _186_["line"] local ok, codeline = pcall(read_line, filename, line, source) local out = {msg, ""} if (ok and codeline) then if col then - table.insert(out, highlight_line(codeline, col, endcol)) + table.insert(out, highlight_line(codeline, col, endcol, opts)) else table.insert(out, codeline) end - else end for _, suggestion in ipairs((suggest(msg) or {})) do table.insert(out, ("* Try %s."):format(suggestion)) end return table.concat(out, "\n") end - local function assert_compile(condition, msg, ast, source) + local function assert_compile(condition, msg, ast, source, opts) if not condition then - local _let_186_ = utils["ast-source"](ast) - local filename = _let_186_["filename"] - local line = _let_186_["line"] - local col = _let_186_["col"] - error(friendly_msg(("Compile error in %s:%s:%s\n %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source), 0) - else + local _189_ = utils["ast-source"](ast) + local col = _189_["col"] + local filename = _189_["filename"] + local line = _189_["line"] + error(friendly_msg(("%s:%s:%s Compile error: %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source, opts), 0) end return condition end - local function parse_error(msg, filename, line, col, source) - return error(friendly_msg(("Parse error in %s:%s:%s\n %s"):format(filename, line, col, msg), {filename = filename, line = line, col = col}, source), 0) + local function parse_error(msg, filename, line, col, source, opts) + return error(friendly_msg(("%s:%s:%s Parse error: %s"):format(filename, line, col, msg), {col = col, filename = filename, line = line}, source, opts), 0) end return {["assert-compile"] = assert_compile, ["parse-error"] = parse_error} end @@ -3528,54 +3456,53 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( local unpack = (table.unpack or _G.unpack) local function granulate(getchunk) local c, index, done_3f = "", 1, false - local function _188_(parser_state) + local function _191_(parser_state) if not done_3f then if (index <= #c) then local b = c:byte(index) index = (index + 1) return b else - local _189_ = getchunk(parser_state) - local function _190_() - local char = _189_ + local _192_0 = getchunk(parser_state) + local function _193_() + local char = _192_0 return (char ~= "") end - if ((nil ~= _189_) and _190_()) then - local char = _189_ + if ((nil ~= _192_0) and _193_()) then + local char = _192_0 c = char index = 2 return c:byte() - elseif true then - local _ = _189_ - done_3f = true - return nil else + local _ = _192_0 + done_3f = true return nil end end - else - return nil end end - local function _194_() + local function _197_() c = "" return nil end - return _188_, _194_ + return _191_, _197_ end - local function string_stream(str) + local function string_stream(str, _3foptions) local str0 = str:gsub("^#!", ";;") + if _3foptions then + _3foptions.source = str0 + end local index = 1 - local function _195_() + local function _199_() local r = str0:byte(index) index = (index + 1) return r end - return _195_ + return _199_ end - local delims = {[40] = 41, [41] = true, [91] = 93, [93] = true, [123] = 125, [125] = true} + local delims = {[123] = 125, [125] = true, [40] = 41, [41] = true, [91] = 93, [93] = true} local function sym_char_3f(b) - local b0 + local b0 = nil if ("number" == type(b)) then b0 = b else @@ -3585,24 +3512,22 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"} local function char_starter_3f(b) - return ((function(_197_,_198_,_199_) return (_197_ < _198_) and (_198_ < _199_) end)(1,b,127) or (function(_200_,_201_,_202_) return (_200_ < _201_) and (_201_ < _202_) end)(192,b,247)) + return (((1 < b) and (b < 127)) or ((192 < b) and (b < 247))) end - local function parser_fn(getbyte, filename, _203_) - local _arg_204_ = _203_ - local source = _arg_204_["source"] - local unfriendly = _arg_204_["unfriendly"] - local comments = _arg_204_["comments"] - local options = _arg_204_ + local function parser_fn(getbyte, filename, _201_0) + local _202_ = _201_0 + local options = _202_ + local comments = _202_["comments"] + local source = _202_["source"] + local unfriendly = _202_["unfriendly"] local stack = {} local line, byteindex, col, prev_col, lastb = 1, 0, 0, 0, nil local function ungetb(ub) if char_starter_3f(ub) then col = (col - 1) - else end if (ub == 10) then line, col = (line - 1), prev_col - else end byteindex = (byteindex - 1) lastb = ub @@ -3618,24 +3543,21 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( byteindex = (byteindex + 1) if (r and char_starter_3f(r)) then col = (col + 1) - else end if (r == 10) then line, col, prev_col = (line + 1), 0, col - else end return r end local function whitespace_3f(b) - local function _214_() - local t_213_ = options.whitespace - if (nil ~= t_213_) then - t_213_ = (t_213_)[b] - else + local function _209_() + local _208_0 = options.whitespace + if (nil ~= _208_0) then + _208_0 = _208_0[b] end - return t_213_ + return _208_0 end - return ((b == 32) or (function(_210_,_211_,_212_) return (_210_ <= _211_) and (_211_ <= _212_) end)(9,b,13) or _214_()) + return ((b == 32) or ((9 <= b) and (b <= 13)) or _209_()) end local function parse_error(msg, _3fcol_adjust) local col0 = (col + (_3fcol_adjust or -1)) @@ -3644,10 +3566,8 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if (unfriendly or not _G.io or not _G.io.read) then return error(string.format("%s:%s:%s Parse error: %s", filename, (line or "?"), col0, msg), 0) else - return friend["parse-error"](msg, filename, (line or "?"), col0, source) + return friend["parse-error"](msg, filename, (line or "?"), col0, source, options) end - else - return nil end end local function parse_stream() @@ -3657,29 +3577,27 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return nil end local function dispatch(v) - local _218_ = stack[#stack] - if (_218_ == nil) then + local _213_0 = stack[#stack] + if (_213_0 == nil) then retval, done_3f, whitespace_since_dispatch = v, true, false return nil - elseif ((_G.type(_218_) == "table") and (nil ~= (_218_).prefix)) then - local prefix = (_218_).prefix - local source0 + elseif ((_G.type(_213_0) == "table") and (nil ~= _213_0.prefix)) then + local prefix = _213_0.prefix + local source0 = nil do - local _219_ = table.remove(stack) - set_source_fields(_219_) - source0 = _219_ + local _214_0 = table.remove(stack) + set_source_fields(_214_0) + source0 = _214_0 end local list = utils.list(utils.sym(prefix, source0), v) for k, v0 in pairs(source0) do list[k] = v0 end return dispatch(list) - elseif (nil ~= _218_) then - local top = _218_ + elseif (nil ~= _213_0) then + local top = _213_0 whitespace_since_dispatch = false return table.insert(top, v) - else - return nil end end local function close_list(list) @@ -3693,27 +3611,27 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return dispatch(val) end local function add_comment_at(comments0, index, node) - local _221_ = (comments0)[index] - if (nil ~= _221_) then - local existing = _221_ + local _216_0 = comments0[index] + if (nil ~= _216_0) then + local existing = _216_0 return table.insert(existing, node) - elseif true then - local _ = _221_ - comments0[index] = {node} - return nil else + local _ = _216_0 + comments0[index] = {node} return nil end end local function next_noncomment(tbl, i) if utils["comment?"](tbl[i]) then return next_noncomment(tbl, (i + 1)) + elseif (utils.sym(":") == tbl[i]) then + return tostring(tbl[(i + 1)]) else return tbl[i] end end local function extract_comments(tbl) - local comments0 = {keys = {}, values = {}, last = {}} + local comments0 = {keys = {}, last = {}, values = {}} while utils["comment?"](tbl[#tbl]) do table.insert(comments0.last, 1, table.remove(tbl)) end @@ -3730,7 +3648,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( for i = #tbl, 1, -1 do if utils["comment?"](tbl[i]) then table.remove(tbl, i) - else end end return comments0 @@ -3742,13 +3659,11 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if ((#tbl % 2) ~= 0) then byteindex = (byteindex - 1) parse_error("expected even number of values in table literal") - else end setmetatable(val, tbl) for i = 1, #tbl, 2 do if ((tostring(tbl[i]) == ":") and utils["sym?"](tbl[(i + 1)]) and utils["sym?"](tbl[i])) then tbl[i] = tostring(tbl[(i + 1)]) - else end val[tbl[i]] = tbl[(i + 1)] table.insert(keys, tbl[i]) @@ -3761,11 +3676,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( local top = table.remove(stack) if (top == nil) then parse_error(("unexpected closing delimiter " .. string.char(b))) - else end if (top.closer and (top.closer ~= b)) then parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) - else end set_source_fields(top) if (b == 41) then @@ -3778,20 +3691,18 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end local function badend(cause) local accum = utils.map(stack, "closer") - local _231_ + local _226_ if (#stack == 1) then - _231_ = "" + _226_ = "" else - _231_ = "s" + _226_ = "s" end - parse_error(string.format("expected closing delimiter%s %s", _231_, string.char(unpack(accum)))) + parse_error(string.format("expected closing delimiter%s %s", _226_, string.char(unpack(accum)))) if (cause == "eof") then for i = #accum, 2, -1 do close_table(accum[i]) end return accum[1] - else - return nil end end local function skip_whitespace(b) @@ -3806,43 +3717,37 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end local function parse_comment(b, contents) if (b and (10 ~= b)) then - local function _236_() - local _235_ = contents - table.insert(_235_, string.char(b)) - return _235_ + local function _230_() + table.insert(contents, string.char(b)) + return contents end - return parse_comment(getb(), _236_()) + return parse_comment(getb(), _230_()) elseif comments then ungetb(10) - return dispatch(utils.comment(table.concat(contents), {line = (line - 1), filename = filename})) - else - return nil + return dispatch(utils.comment(table.concat(contents), {filename = filename, line = line})) end end local function open_table(b) if not whitespace_since_dispatch then parse_error(("expected whitespace before opening delimiter " .. string.char(b))) - else end - return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line, col = (col - 1)}) + return table.insert(stack, {bytestart = byteindex, closer = delims[b], col = (col - 1), filename = filename, line = line}) end local function parse_string_loop(chars, b, state) table.insert(chars, b) - local state0 + local state0 = nil do - local _239_ = {state, b} - if ((_G.type(_239_) == "table") and ((_239_)[1] == "base") and ((_239_)[2] == 92)) then + local _233_0 = {state, b} + if ((_G.type(_233_0) == "table") and (_233_0[1] == "base") and (_233_0[2] == 92)) then state0 = "backslash" - elseif ((_G.type(_239_) == "table") and ((_239_)[1] == "base") and ((_239_)[2] == 34)) then + elseif ((_G.type(_233_0) == "table") and (_233_0[1] == "base") and (_233_0[2] == 34)) then state0 = "done" - elseif ((_G.type(_239_) == "table") and ((_239_)[1] == "backslash") and ((_239_)[2] == 10)) then + elseif ((_G.type(_233_0) == "table") and (_233_0[1] == "backslash") and (_233_0[2] == 10)) then table.remove(chars, (#chars - 1)) state0 = "base" - elseif true then - local _ = _239_ - state0 = "base" else - state0 = nil + local _ = _233_0 + state0 = "base" end end if (b and (state0 ~= "done")) then @@ -3852,39 +3757,34 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end end local function escape_char(c) - return ({[7] = "\\a", [8] = "\\b", [9] = "\\t", [10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r"})[c:byte()] + return ({[10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r", [7] = "\\a", [8] = "\\b", [9] = "\\t"})[c:byte()] end local function parse_string() table.insert(stack, {closer = 34}) local chars = {34} if not parse_string_loop(chars, getb(), "base") then badend("string") - else end table.remove(stack) local raw = string.char(unpack(chars)) local formatted = raw:gsub("[\7-\13]", escape_char) - local _243_ = (rawget(_G, "loadstring") or load)(("return " .. formatted)) - if (nil ~= _243_) then - local load_fn = _243_ + local _237_0 = (rawget(_G, "loadstring") or load)(("return " .. formatted)) + if (nil ~= _237_0) then + local load_fn = _237_0 return dispatch(load_fn()) - elseif (_243_ == nil) then + elseif (_237_0 == nil) then return parse_error(("Invalid string: " .. raw)) - else - return nil end end local function parse_prefix(b) - table.insert(stack, {prefix = prefixes[b], filename = filename, line = line, bytestart = byteindex, col = (col - 1)}) + table.insert(stack, {bytestart = byteindex, col = (col - 1), filename = filename, line = line, prefix = prefixes[b]}) local nextb = getb() if (whitespace_3f(nextb) or (true == delims[nextb])) then if (b ~= 35) then parse_error("invalid whitespace after quoting prefix") - else end table.remove(stack) dispatch(utils.sym("#")) - else end return ungetb(nextb) end @@ -3895,7 +3795,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( else if b then ungetb(b) - else end return chars end @@ -3906,16 +3805,14 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\"")))) return true else - local _249_ = tonumber(number_with_stripped_underscores) - if (nil ~= _249_) then - local x = _249_ + local _243_0 = tonumber(number_with_stripped_underscores) + if (nil ~= _243_0) then + local x = _243_0 dispatch(x) return true - elseif true then - local _ = _249_ - return false else - return nil + local _ = _243_0 + return false end end end @@ -3933,12 +3830,11 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( parse_error(("malformed multisym: " .. rawstr), col_adjust(":$")) elseif rawstr:match(":.+[%.:]") then parse_error(("method must be last component of multisym: " .. rawstr), col_adjust(":.+[%.:]")) - else end return rawstr end local function parse_sym(b) - local source0 = {bytestart = byteindex, filename = filename, line = line, col = (col - 1)} + local source0 = {bytestart = byteindex, col = (col - 1), filename = filename, line = line} local rawstr = string.char(unpack(parse_sym_loop({b}, getb()))) set_source_fields(source0) if (rawstr == "true") then @@ -3951,8 +3847,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return dispatch(rawstr:sub(2)) elseif not parse_number(rawstr) then return dispatch(utils.sym(check_malformed_sym(rawstr), source0)) - else - return nil end end local function parse_loop(b) @@ -3971,7 +3865,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( parse_sym(b) elseif not utils["hook-opts"]("illegal-char", options, b, getb, ungetb, dispatch) then parse_error(("invalid character: " .. string.char(b))) - else end if not b then return nil @@ -3983,70 +3876,113 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return parse_loop(skip_whitespace(getb())) end - local function _256_() + local function _250_() stack, line, byteindex, col, lastb = {}, 1, 0, 0, nil return nil end - return parse_stream, _256_ + return parse_stream, _250_ end local function parser(stream_or_string, _3ffilename, _3foptions) local filename = (_3ffilename or "unknown") local options = (_3foptions or utils.root.options or {}) assert(("string" == type(filename)), "expected filename as second argument to parser") if ("string" == type(stream_or_string)) then - return parser_fn(string_stream(stream_or_string), filename, options) + return parser_fn(string_stream(stream_or_string, options), filename, options) else return parser_fn(stream_or_string, filename, options) end end - return {granulate = granulate, parser = parser, ["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f} + return {["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f, granulate = granulate, parser = parser} end -local utils +local utils = nil package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) - local type_order = {number = 1, boolean = 2, string = 3, table = 4, ["function"] = 5, userdata = 6, thread = 7} + local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6} + local default_opts = {["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["escape-newlines?"] = false, ["line-length"] = 80, ["max-sparse-gap"] = 10, ["metamethod?"] = true, ["one-line?"] = false, ["prefer-colon?"] = false, ["utf8?"] = true, depth = 128} local lua_pairs = pairs local lua_ipairs = ipairs local function pairs(t) - local _1_ = getmetatable(t) - if ((_G.type(_1_) == "table") and (nil ~= (_1_).__pairs)) then - local p = (_1_).__pairs + local _1_0 = getmetatable(t) + if ((_G.type(_1_0) == "table") and (nil ~= _1_0.__pairs)) then + local p = _1_0.__pairs return p(t) - elseif true then - local _ = _1_ - return lua_pairs(t) else - return nil + local _ = _1_0 + return lua_pairs(t) end end local function ipairs(t) - local _3_ = getmetatable(t) - if ((_G.type(_3_) == "table") and (nil ~= (_3_).__ipairs)) then - local i = (_3_).__ipairs + local _3_0 = getmetatable(t) + if ((_G.type(_3_0) == "table") and (nil ~= _3_0.__ipairs)) then + local i = _3_0.__ipairs return i(t) - elseif true then - local _ = _3_ - return lua_ipairs(t) else - return nil + local _ = _3_0 + return lua_ipairs(t) end end local function length_2a(t) - local _5_ = getmetatable(t) - if ((_G.type(_5_) == "table") and (nil ~= (_5_).__len)) then - local l = (_5_).__len + local _5_0 = getmetatable(t) + if ((_G.type(_5_0) == "table") and (nil ~= _5_0.__len)) then + local l = _5_0.__len return l(t) - elseif true then - local _ = _5_ - return #t else - return nil + local _ = _5_0 + return #t end end - local function sort_keys(_7_, _9_) - local _arg_8_ = _7_ - local a = _arg_8_[1] - local _arg_10_ = _9_ - local b = _arg_10_[1] + local function get_default(key) + local _7_0 = default_opts[key] + if (_7_0 == nil) then + return error(("option '%s' doesn't have a default value, use the :after key to set it"):format(tostring(key))) + elseif (nil ~= _7_0) then + local v = _7_0 + return v + end + end + local function getopt(options, key) + local val = options[key] + local _9_0 = val + if ((_G.type(_9_0) == "table") and (nil ~= _9_0.once)) then + local val_2a = _9_0.once + return val_2a + else + local _ = _9_0 + return val + end + end + local function normalize_opts(options) + local tbl_14_ = {} + for k, v in pairs(options) do + local k_15_, v_16_ = nil, nil + local function _12_() + local _11_0 = v + if ((_G.type(_11_0) == "table") and (nil ~= _11_0.after)) then + local val = _11_0.after + return val + else + local function _13_() + return v.once + end + if ((_G.type(_11_0) == "table") and _13_()) then + return get_default(k) + else + local _ = _11_0 + return v + end + end + end + k_15_, v_16_ = k, _12_() + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end + end + return tbl_14_ + end + local function sort_keys(_16_0, _18_0) + local _17_ = _16_0 + local a = _17_[1] + local _19_ = _18_0 + local b = _19_[1] local ta = type(a) local tb = type(b) if ((ta == tb) and ((ta == "string") or (ta == "number"))) then @@ -4069,25 +4005,23 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local gap = 0 if (0 < length_2a(kv)) then local i = 0 - for _, _13_ in ipairs(kv) do - local _each_14_ = _13_ - local k = _each_14_[1] + for _, _22_0 in ipairs(kv) do + local _23_ = _22_0 + local k = _23_[1] if (gap < (k - i)) then gap = (k - i) - else end i = k end - else end return gap end local function fill_gaps(kv) local missing_indexes = {} local i = 0 - for _, _17_ in ipairs(kv) do - local _each_18_ = _17_ - local j = _each_18_[1] + for _, _26_0 in ipairs(kv) do + local _27_ = _26_0 + local j = _27_[1] i = (i + 1) while (i < j) do table.insert(missing_indexes, i) @@ -4106,7 +4040,6 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) for k, v in pairs(t) do if ((type(k) ~= "number") or (k < 1)) then assoc_3f = true - else end insert(kv, {k, v}) end @@ -4117,19 +4050,18 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else fill_gaps(kv) end - else end if (length_2a(kv) == 0) then return kv, "empty" else - local function _22_() + local function _31_() if assoc_3f then return "table" else return "seq" end end - return kv, _22_() + return kv, _31_() end end local function count_table_appearances(t, appearances) @@ -4143,40 +4075,34 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else appearances[t] = ((appearances[t] or 0) + 1) end - else end return appearances end local function save_table(t, seen) local seen0 = (seen or {len = 0}) local id = (seen0.len + 1) - if not (seen0)[t] then + if not seen0[t] then seen0[t] = id seen0.len = id - else end return seen0 end local function detect_cycle(t, seen, _3fk) if ("table" == type(t)) then seen[t] = true - local _27_, _28_ = next(t, _3fk) - if ((nil ~= _27_) and (nil ~= _28_)) then - local k = _27_ - local v = _28_ + local _36_0, _37_0 = next(t, _3fk) + if ((nil ~= _36_0) and (nil ~= _37_0)) then + local k = _36_0 + local v = _37_0 return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k)) - else - return nil end - else - return nil end end local function visible_cycle_3f(t, options) - return (options["detect-cycles?"] and detect_cycle(t, {}) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) + return (getopt(options, "detect-cycles?") and detect_cycle(t, {}) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) end local function table_indent(indent, id) - local opener_length + local opener_length = nil if id then opener_length = (length_2a(tostring(id)) + 2) else @@ -4187,31 +4113,31 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local pp = nil local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix, last_comment_3f) local indent_str = ("\n" .. string.rep(" ", indent)) - local open - local function _32_() + local open = nil + local function _41_() if ("seq" == table_type) then return "[" else return "{" end end - open = ((prefix or "") .. _32_()) - local close + open = ((prefix or "") .. _41_()) + local close = nil if ("seq" == table_type) then close = "]" else close = "}" end local oneline = (open .. table.concat(elements, " ") .. close) - if (not options["one-line?"] and (multiline_3f or (options["line-length"] < (indent + length_2a(oneline))) or last_comment_3f)) then - local function _34_() + if (not getopt(options, "one-line?") and (multiline_3f or (options["line-length"] < (indent + length_2a(oneline))) or last_comment_3f)) then + local function _43_() if last_comment_3f then return indent_str else return "" end end - return (open .. table.concat(elements, indent_str) .. _34_() .. close) + return (open .. table.concat(elements, indent_str) .. _43_() .. close) else return oneline end @@ -4236,49 +4162,49 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local id = options.seen[t] if (options.depth <= options.level) then return "{...}" - elseif (id and options["detect-cycles?"]) then + elseif (id and getopt(options, "detect-cycles?")) then return ("@" .. id .. "{...}") else local visible_cycle_3f0 = visible_cycle_3f(t, options) local id0 = (visible_cycle_3f0 and options.seen[t]) local indent0 = table_indent(indent, id0) - local slength - if options["utf8?"] then + local slength = nil + if getopt(options, "utf8?") then slength = utf8_len else - local function _37_(_241) + local function _46_(_241) return #_241 end - slength = _37_ + slength = _46_ end - local prefix + local prefix = nil if visible_cycle_3f0 then prefix = ("@" .. id0) else prefix = "" end - local items + local items = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for _, _40_ in ipairs(kv) do - local _each_41_ = _40_ - local k = _each_41_[1] - local v = _each_41_[2] - local val_16_auto + local options0 = normalize_opts(options) + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _49_0 in ipairs(kv) do + local _50_ = _49_0 + local k = _50_[1] + local v = _50_[2] + local val_19_ = nil do - local k0 = pp(k, options, (indent0 + 1), true) - local v0 = pp(v, options, (indent0 + slength(k0) + 1)) + local k0 = pp(k, options0, (indent0 + 1), true) + local v0 = pp(v, options0, (indent0 + slength(k0) + 1)) multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) - val_16_auto = (k0 .. " " .. v0) + val_19_ = (k0 .. " " .. v0) end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - items = tbl_14_auto + items = tbl_17_ end return concat_table_lines(items, options, multiline_3f, indent0, "table", prefix, false) end @@ -4288,69 +4214,68 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local id = options.seen[t] if (options.depth <= options.level) then return "[...]" - elseif (id and options["detect-cycles?"]) then + elseif (id and getopt(options, "detect-cycles?")) then return ("@" .. id .. "[...]") else local visible_cycle_3f0 = visible_cycle_3f(t, options) local id0 = (visible_cycle_3f0 and options.seen[t]) local indent0 = table_indent(indent, id0) - local prefix + local prefix = nil if visible_cycle_3f0 then prefix = ("@" .. id0) else prefix = "" end local last_comment_3f = comment_3f(t[#t]) - local items + local items = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto - for _, _45_ in ipairs(kv) do - local _each_46_ = _45_ - local _0 = _each_46_[1] - local v = _each_46_[2] - local val_16_auto + local options0 = normalize_opts(options) + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _54_0 in ipairs(kv) do + local _55_ = _54_0 + local _0 = _55_[1] + local v = _55_[2] + local val_19_ = nil do - local v0 = pp(v, options, indent0) + local v0 = pp(v, options0, indent0) multiline_3f = (multiline_3f or v0:find("\n") or v0:find("^;")) - val_16_auto = v0 + val_19_ = v0 end - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - items = tbl_14_auto + items = tbl_17_ end return concat_table_lines(items, options, multiline_3f, indent0, "seq", prefix, last_comment_3f) end end local function concat_lines(lines, options, indent, force_multi_line_3f) if (length_2a(lines) == 0) then - if options["empty-as-sequence?"] then + if getopt(options, "empty-as-sequence?") then return "[]" else return "{}" end else - local oneline - local _50_ + local oneline = nil + local _59_ do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, line in ipairs(lines) do - local val_16_auto = line:gsub("^%s+", "") - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = line:gsub("^%s+", "") + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _50_ = tbl_14_auto + _59_ = tbl_17_ end - oneline = table.concat(_50_, " ") - if (not options["one-line?"] and (force_multi_line_3f or oneline:find("\n") or (options["line-length"] < (indent + length_2a(oneline))))) then + oneline = table.concat(_59_, " ") + if (not getopt(options, "one-line?") and (force_multi_line_3f or oneline:find("\n") or (options["line-length"] < (indent + length_2a(oneline))))) then return table.concat(lines, ("\n" .. string.rep(" ", indent))) else return oneline @@ -4359,106 +4284,106 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end local function pp_metamethod(t, metamethod, options, indent) if (options.depth <= options.level) then - if options["empty-as-sequence?"] then + if getopt(options, "empty-as-sequence?") then return "[...]" else return "{...}" end else - local _ - local function _55_(_241) + local _ = nil + local function _64_(_241) return visible_cycle_3f(_241, options) end - options["visible-cycle?"] = _55_ + options["visible-cycle?"] = _64_ _ = nil - local lines, force_multi_line_3f = metamethod(t, pp, options, indent) + local lines, force_multi_line_3f = nil, nil + do + local options0 = normalize_opts(options) + lines, force_multi_line_3f = metamethod(t, pp, options0, indent) + end options["visible-cycle?"] = nil - local _56_ = type(lines) - if (_56_ == "string") then + local _65_0 = type(lines) + if (_65_0 == "string") then return lines - elseif (_56_ == "table") then + elseif (_65_0 == "table") then return concat_lines(lines, options, indent, force_multi_line_3f) - elseif true then - local _0 = _56_ - return error("__fennelview metamethod must return a table of lines") else - return nil + local _0 = _65_0 + return error("__fennelview metamethod must return a table of lines") end end end local function pp_table(x, options, indent) options.level = (options.level + 1) - local x0 + local x0 = nil do - local _59_ - if options["metamethod?"] then - local _60_ = x - if (nil ~= _60_) then - local _61_ = getmetatable(_60_) - if (nil ~= _61_) then - _59_ = (_61_).__fennelview + local _68_0 = nil + if getopt(options, "metamethod?") then + local _69_0 = x + if (nil ~= _69_0) then + local _70_0 = getmetatable(_69_0) + if (nil ~= _70_0) then + _68_0 = _70_0.__fennelview else - _59_ = _61_ + _68_0 = _70_0 end else - _59_ = _60_ + _68_0 = _69_0 end else - _59_ = nil + _68_0 = nil end - if (nil ~= _59_) then - local metamethod = _59_ + if (nil ~= _68_0) then + local metamethod = _68_0 x0 = pp_metamethod(x, metamethod, options, indent) - elseif true then - local _ = _59_ - local _65_, _66_ = table_kv_pairs(x, options) - if (true and (_66_ == "empty")) then - local _0 = _65_ - if options["empty-as-sequence?"] then + else + local _ = _68_0 + local _74_0, _75_0 = table_kv_pairs(x, options) + if (true and (_75_0 == "empty")) then + local _0 = _74_0 + if getopt(options, "empty-as-sequence?") then x0 = "[]" else x0 = "{}" end - elseif ((nil ~= _65_) and (_66_ == "table")) then - local kv = _65_ + elseif ((nil ~= _74_0) and (_75_0 == "table")) then + local kv = _74_0 x0 = pp_associative(x, kv, options, indent) - elseif ((nil ~= _65_) and (_66_ == "seq")) then - local kv = _65_ + elseif ((nil ~= _74_0) and (_75_0 == "seq")) then + local kv = _74_0 x0 = pp_sequence(x, kv, options, indent) else - x0 = nil - end - else x0 = nil + end end end options.level = (options.level - 1) return x0 end local function number__3estring(n) - local _70_ = string.gsub(tostring(n), ",", ".") - return _70_ + local _79_0 = string.gsub(tostring(n), ",", ".") + return _79_0 end local function colon_string_3f(s) return s:find("^[-%w?^_!$%&*+./@|<=>]+$") end - local utf8_inits = {{["min-byte"] = 0, ["max-byte"] = 127, ["min-code"] = 0, ["max-code"] = 127, len = 1}, {["min-byte"] = 192, ["max-byte"] = 223, ["min-code"] = 128, ["max-code"] = 2047, len = 2}, {["min-byte"] = 224, ["max-byte"] = 239, ["min-code"] = 2048, ["max-code"] = 65535, len = 3}, {["min-byte"] = 240, ["max-byte"] = 247, ["min-code"] = 65536, ["max-code"] = 1114111, len = 4}} + local utf8_inits = {{["max-byte"] = 127, ["max-code"] = 127, ["min-byte"] = 0, ["min-code"] = 0, len = 1}, {["max-byte"] = 223, ["max-code"] = 2047, ["min-byte"] = 192, ["min-code"] = 128, len = 2}, {["max-byte"] = 239, ["max-code"] = 65535, ["min-byte"] = 224, ["min-code"] = 2048, len = 3}, {["max-byte"] = 247, ["max-code"] = 1114111, ["min-byte"] = 240, ["min-code"] = 65536, len = 4}} local function utf8_escape(str) local function validate_utf8(str0, index) local inits = utf8_inits local byte = string.byte(str0, index) - local init + local init = nil do local ret = nil for _, init0 in ipairs(inits) do if ret then break end - ret = (byte and (function(_71_,_72_,_73_) return (_71_ <= _72_) and (_72_ <= _73_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) + ret = (byte and (function(_80_,_81_,_82_) return (_80_ <= _81_) and (_81_ <= _82_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) end init = ret end - local code - local function _74_() - local code0 + local code = nil + local function _83_() + local code0 = nil if init then code0 = (byte - init["min-byte"]) else @@ -4466,15 +4391,13 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end for i = (index + 1), (index + init.len + -1) do local byte0 = string.byte(str0, i) - code0 = (byte0 and code0 and (function(_76_,_77_,_78_) return (_76_ <= _77_) and (_77_ <= _78_) end)(128,byte0,191) and ((code0 * 64) + (byte0 - 128))) + code0 = (byte0 and code0 and ((128 <= byte0) and (byte0 <= 191)) and ((code0 * 64) + (byte0 - 128))) end return code0 end - code = (init and _74_()) - if (code and (function(_79_,_80_,_81_) return (_79_ <= _80_) and (_80_ <= _81_) end)(init["min-code"],code,init["max-code"]) and not (function(_82_,_83_,_84_) return (_82_ <= _83_) and (_83_ <= _84_) end)(55296,code,57343)) then + code = (init and _83_()) + if (code and (function(_85_,_86_,_87_) return (_85_ <= _86_) and (_86_ <= _87_) end)(init["min-code"],code,init["max-code"]) and not ((55296 <= code) and (code <= 57343))) then return init.len - else - return nil end end local index = 1 @@ -4485,7 +4408,6 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) table.insert(output, string.sub(str, index, (nexti + (len or 0) + -1))) if (not len and (nexti <= #str)) then table.insert(output, string.format("\\%03d", string.byte(str, nexti))) - else end if len then index = (nexti + len) @@ -4496,27 +4418,39 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return table.concat(output) end local function pp_string(str, options, indent) - local escs - local _88_ - if (options["escape-newlines?"] and (length_2a(str) < (options["line-length"] - indent))) then - _88_ = "\\n" + local len = length_2a(str) + local esc_newline_3f = ((len < 2) or (getopt(options, "escape-newlines?") and (len < (options["line-length"] - indent)))) + local escs = nil + local _91_ + if esc_newline_3f then + _91_ = "\\n" else - _88_ = "\n" + _91_ = "\n" end - local function _90_(_241, _242) + local function _93_(_241, _242) return ("\\%03d"):format(_242:byte()) end - escs = setmetatable({["\7"] = "\\a", ["\8"] = "\\b", ["\12"] = "\\f", ["\11"] = "\\v", ["\13"] = "\\r", ["\9"] = "\\t", ["\\"] = "\\\\", ["\""] = "\\\"", ["\n"] = _88_}, {__index = _90_}) + escs = setmetatable({["\""] = "\\\"", ["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\\"] = "\\\\", ["\n"] = _91_}, {__index = _93_}) local str0 = ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"") - if options["utf8?"] then + if getopt(options, "utf8?") then return utf8_escape(str0) else return str0 end end local function make_options(t, options) - local defaults = {["line-length"] = 80, ["one-line?"] = false, depth = 128, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["metamethod?"] = true, ["prefer-colon?"] = false, ["escape-newlines?"] = false, ["utf8?"] = true, ["max-sparse-gap"] = 10} - local overrides = {level = 0, appearances = count_table_appearances(t, {}), seen = {len = 0}} + local defaults = nil + do + local tbl_14_ = {} + for k, v in pairs(default_opts) do + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end + end + defaults = tbl_14_ + end + local overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}} for k, v in pairs((options or {})) do defaults[k] = v end @@ -4525,39 +4459,39 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return defaults end - local function _92_(x, options, indent, colon_3f) + local function _96_(x, options, indent, colon_3f) local indent0 = (indent or 0) local options0 = (options or make_options(x)) - local x0 + local x0 = nil if options0.preprocess then x0 = options0.preprocess(x, options0) else x0 = x end local tv = type(x0) - local function _95_() - local _94_ = getmetatable(x0) - if (nil ~= _94_) then - return (_94_).__fennelview + local function _99_() + local _98_0 = getmetatable(x0) + if (nil ~= _98_0) then + return _98_0.__fennelview else - return _94_ + return _98_0 end end - if ((tv == "table") or ((tv == "userdata") and _95_())) then + if ((tv == "table") or ((tv == "userdata") and _99_())) then return pp_table(x0, options0, indent0) elseif (tv == "number") then return number__3estring(x0) else - local function _97_() + local function _101_() if (colon_3f ~= nil) then return colon_3f elseif ("function" == type(options0["prefer-colon?"])) then return options0["prefer-colon?"](x0) else - return options0["prefer-colon?"] + return getopt(options0, "prefer-colon?") end end - if ((tv == "string") and colon_string_3f(x0) and _97_()) then + if ((tv == "string") and colon_string_3f(x0) and _101_()) then return (":" .. x0) elseif (tv == "string") then return pp_string(x0, options0, indent0) @@ -4568,7 +4502,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end end end - pp = _92_ + pp = _96_ local function view(x, _3foptions) return pp(x, make_options(x, _3foptions), 0) end @@ -4576,12 +4510,12 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...) local view = require("fennel.view") - local version = "1.3.0-dev" + local version = "1.3.1-dev" local function luajit_vm_3f() return ((nil ~= _G.jit) and (type(_G.jit) == "table") and (nil ~= _G.jit.on) and (nil ~= _G.jit.off) and (type(_G.jit.version_num) == "number")) end local function luajit_vm_version() - local jit_os + local jit_os = nil if (_G.jit.os == "OSX") then jit_os = "macOS" else @@ -4610,21 +4544,17 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function warn(message) if (_G.io and _G.io.stderr) then return (_G.io.stderr):write(("--WARNING: %s\n"):format(tostring(message))) - else - return nil end end - local len + local len = nil do - local _102_, _103_ = pcall(require, "utf8") - if ((_102_ == true) and (nil ~= _103_)) then - local utf8 = _103_ + local _106_0, _107_0 = pcall(require, "utf8") + if ((_106_0 == true) and (nil ~= _107_0)) then + local utf8 = _107_0 len = utf8.len - elseif true then - local _ = _102_ - len = string.len else - len = nil + local _ = _106_0 + len = string.len end end local function mt_keys_in_order(t, out, used_keys) @@ -4632,67 +4562,60 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. if (t[k] and not used_keys[k]) then used_keys[k] = true table.insert(out, k) - else end end for k in pairs(t) do if not used_keys[k] then table.insert(out, k) - else end end return out end local function stablepairs(t) - local keys - local _108_ + local keys = nil + local _112_ do - local t_107_ = getmetatable(t) - if (nil ~= t_107_) then - t_107_ = (t_107_).keys - else + local _111_0 = getmetatable(t) + if (nil ~= _111_0) then + _111_0 = _111_0.keys end - _108_ = t_107_ + _112_ = _111_0 end - if _108_ then + if _112_ then keys = mt_keys_in_order(t, {}, {}) else - local _110_ + local _114_0 = nil do - local tbl_14_auto = {} - local i_15_auto = #tbl_14_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for k in pairs(t) do - local val_16_auto = k - if (nil ~= val_16_auto) then - i_15_auto = (i_15_auto + 1) - do end (tbl_14_auto)[i_15_auto] = val_16_auto - else + local val_19_ = k + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _110_ = tbl_14_auto + _114_0 = tbl_17_ end - local function _112_(_241, _242) + local function _116_(_241, _242) return (tostring(_241) < tostring(_242)) end - table.sort(_110_, _112_) - keys = _110_ + table.sort(_114_0, _116_) + keys = _114_0 end - local succ + local succ = nil do - local tbl_11_auto = {} + local tbl_14_ = {} for i, k in ipairs(keys) do - local _114_, _115_ = k, keys[(i + 1)] - if ((nil ~= _114_) and (nil ~= _115_)) then - local k_12_auto = _114_ - local v_13_auto = _115_ - tbl_11_auto[k_12_auto] = v_13_auto - else + local k_15_, v_16_ = k, keys[(i + 1)] + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - succ = tbl_11_auto + succ = tbl_14_ end local function stablenext(tbl, key) - local next_key + local next_key = nil if (key == nil) then next_key = keys[1] else @@ -4707,103 +4630,113 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. if (0 == #path) then return _3ffallback else - local _118_ + local _120_0 = nil do local t = tbl for _, k in ipairs(path) do if (nil == t) then break end - local _119_ = type(t) - if (_119_ == "table") then + local _121_0 = type(t) + if (_121_0 == "table") then t = t[k] else - t = nil + t = nil end end - _118_ = t + _120_0 = t end - if (nil ~= _118_) then - local res = _118_ + if (nil ~= _120_0) then + local res = _120_0 return res - elseif true then - local _ = _118_ - return _3ffallback else - return nil + local _ = _120_0 + return _3ffallback end end end local function map(t, f, _3fout) local out = (_3fout or {}) - local f0 + local f0 = nil if (type(f) == "function") then f0 = f else - local function _123_(_241) - return (_241)[f] + local function _125_(_241) + return _241[f] end - f0 = _123_ + f0 = _125_ end for _, x in ipairs(t) do - local _125_ = f0(x) - if (nil ~= _125_) then - local v = _125_ + local _127_0 = f0(x) + if (nil ~= _127_0) then + local v = _127_0 table.insert(out, v) - else end end return out end local function kvmap(t, f, _3fout) local out = (_3fout or {}) - local f0 + local f0 = nil if (type(f) == "function") then f0 = f else - local function _127_(_241) - return (_241)[f] + local function _129_(_241) + return _241[f] end - f0 = _127_ + f0 = _129_ end for k, x in stablepairs(t) do - local _129_, _130_ = f0(k, x) - if ((nil ~= _129_) and (nil ~= _130_)) then - local key = _129_ - local value = _130_ + local _131_0, _132_0 = f0(k, x) + if ((nil ~= _131_0) and (nil ~= _132_0)) then + local key = _131_0 + local value = _132_0 out[key] = value - elseif (nil ~= _129_) then - local value = _129_ + elseif (nil ~= _131_0) then + local value = _131_0 table.insert(out, value) - else end end return out end local function copy(from, _3fto) - local tbl_11_auto = (_3fto or {}) + local tbl_14_ = (_3fto or {}) for k, v in pairs((from or {})) do - local _132_, _133_ = k, v - if ((nil ~= _132_) and (nil ~= _133_)) then - local k_12_auto = _132_ - local v_13_auto = _133_ - tbl_11_auto[k_12_auto] = v_13_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - return tbl_11_auto + return tbl_14_ end local function member_3f(x, tbl, _3fn) - local _135_ = tbl[(_3fn or 1)] - if (_135_ == x) then + local _135_0 = tbl[(_3fn or 1)] + if (_135_0 == x) then return true - elseif (_135_ == nil) then + elseif (_135_0 == nil) then return nil - elseif true then - local _ = _135_ - return member_3f(x, tbl, ((_3fn or 1) + 1)) else - return nil + local _ = _135_0 + return member_3f(x, tbl, ((_3fn or 1) + 1)) end end + local function maxn(tbl) + local max = 0 + for k in pairs(tbl) do + if ("number" == type(k)) then + max = math.max(max, k) + else + max = max + end + end + return max + end + local function every_3f(t, predicate) + local result = true + for _, item in ipairs(t) do + if not result then break end + result = predicate(item) + end + return result + end local function allpairs(tbl) assert((type(tbl) == "table"), "allpairs expects a table") local t = tbl @@ -4816,17 +4749,13 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. seen[next_state] = true return next_state, value else - local _137_ = getmetatable(t) - if ((_G.type(_137_) == "table") and true) then - local __index = (_137_).__index + local _138_0 = getmetatable(t) + if ((_G.type(_138_0) == "table") and true) then + local __index = _138_0.__index if ("table" == type(__index)) then t = __index return allpairs_next(t) - else - return nil end - else - return nil end end end @@ -4836,19 +4765,22 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return self[1] end local nil_sym = nil - local function list__3estring(self, _3ftostring2) + local function list__3estring(self, _3fview, _3foptions, _3findent) local safe = {} - local max = 0 - for k in pairs(self) do - if ((type(k) == "number") and (max < k)) then - max = k - else + local view0 = nil + if _3fview then + local function _142_(_241) + return _3fview(_241, _3foptions, _3findent) end + view0 = _142_ + else + view0 = view end + local max = maxn(self) for i = 1, max do safe[i] = (((self[i] == nil) and nil_sym) or self[i]) end - return ("(" .. table.concat(map(safe, (_3ftostring2 or view)), " ", 1, max) .. ")") + return ("(" .. table.concat(map(safe, view0), " ", 1, max) .. ")") end local function comment_view(c) return c, true @@ -4859,21 +4791,21 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function sym_3c(a, b) return (a[1] < tostring(b)) end - local symbol_mt = {__fennelview = deref, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "SYMBOL"} - local expr_mt - local function _142_(x) + local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref} + local expr_mt = nil + local function _144_(x) return tostring(deref(x)) end - expr_mt = {__tostring = _142_, "EXPR"} - local list_mt = {__fennelview = list__3estring, __tostring = list__3estring, "LIST"} - local comment_mt = {__fennelview = comment_view, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "COMMENT"} + expr_mt = {"EXPR", __tostring = _144_} + local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring} + local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref} local sequence_marker = {"SEQUENCE"} - local varg_mt = {__fennelview = deref, __tostring = deref, "VARARG"} - local getenv - local function _143_() + local varg_mt = {"VARARG", __fennelview = deref, __tostring = deref} + local getenv = nil + local function _145_() return nil end - getenv = ((os and os.getenv) or _143_) + getenv = ((os and os.getenv) or _145_) local function debug_on_3f(flag) local level = (getenv("FENNEL_DEBUG") or "") return ((level == "all") or level:find(flag)) @@ -4882,61 +4814,64 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return setmetatable({...}, list_mt) end local function sym(str, _3fsource) - local _144_ + local _146_ do - local tbl_11_auto = {str} + local tbl_14_ = {str} for k, v in pairs((_3fsource or {})) do - local _145_, _146_ = nil, nil + local k_15_, v_16_ = nil, nil if (type(k) == "string") then - _145_, _146_ = k, v + k_15_, v_16_ = k, v else - _145_, _146_ = nil + k_15_, v_16_ = nil end - if ((nil ~= _145_) and (nil ~= _146_)) then - local k_12_auto = _145_ - local v_13_auto = _146_ - tbl_11_auto[k_12_auto] = v_13_auto - else + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _144_ = tbl_11_auto + _146_ = tbl_14_ end - return setmetatable(_144_, symbol_mt) + return setmetatable(_146_, symbol_mt) end nil_sym = sym("nil") local function sequence(...) - return setmetatable({...}, {sequence = sequence_marker}) + local function _149_(seq, view0, inspector, indent) + local opts = nil + do + inspector["empty-as-sequence?"] = {after = inspector["empty-as-sequence?"], once = true} + inspector["metamethod?"] = {after = inspector["metamethod?"], once = false} + opts = inspector + end + return view0(seq, opts, indent) + end + return setmetatable({...}, {__fennelview = _149_, sequence = sequence_marker}) end local function expr(strcode, etype) - return setmetatable({type = etype, strcode}, expr_mt) + return setmetatable({strcode, type = etype}, expr_mt) end local function comment_2a(contents, _3fsource) - local _let_149_ = (_3fsource or {}) - local filename = _let_149_["filename"] - local line = _let_149_["line"] - return setmetatable({filename = filename, line = line, contents}, comment_mt) + local _150_ = (_3fsource or {}) + local filename = _150_["filename"] + local line = _150_["line"] + return setmetatable({contents, filename = filename, line = line}, comment_mt) end local function varg(_3fsource) - local _150_ + local _151_ do - local tbl_11_auto = {"..."} + local tbl_14_ = {"..."} for k, v in pairs((_3fsource or {})) do - local _151_, _152_ = nil, nil + local k_15_, v_16_ = nil, nil if (type(k) == "string") then - _151_, _152_ = k, v + k_15_, v_16_ = k, v else - _151_, _152_ = nil + k_15_, v_16_ = nil end - if ((nil ~= _151_) and (nil ~= _152_)) then - local k_12_auto = _151_ - local v_13_auto = _152_ - tbl_11_auto[k_12_auto] = v_13_auto - else + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _150_ = tbl_11_auto + _151_ = tbl_14_ end - return setmetatable(_150_, varg_mt) + return setmetatable(_151_, varg_mt) end local function expr_3f(x) return ((type(x) == "table") and (getmetatable(x) == expr_mt) and x) @@ -4969,25 +4904,30 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. elseif (type(str) ~= "string") then return false else - local parts = {} - for part in str:gmatch("[^%.%:]+[%.%:]?") do - local last_char = part:sub(( - 1)) - if (last_char == ":") then - parts["multi-sym-method-call"] = true - else - end - if ((last_char == ":") or (last_char == ".")) then - parts[(#parts + 1)] = part:sub(1, ( - 2)) - else - parts[(#parts + 1)] = part + local function _154_() + local parts = {} + for part in str:gmatch("[^%.%:]+[%.%:]?") do + local last_char = part:sub(( - 1)) + if (last_char == ":") then + parts["multi-sym-method-call"] = true + end + if ((last_char == ":") or (last_char == ".")) then + parts[(#parts + 1)] = part:sub(1, ( - 2)) + else + parts[(#parts + 1)] = part + end end + return ((0 < #parts) and parts) end - return ((0 < #parts) and (str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte(( - 1)) ~= string.byte(".")) and parts) + return ((str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte(( - 1)) ~= string.byte(".")) and _154_()) end end local function quoted_3f(symbol) return symbol.quoted end + local function idempotent_expr_3f(x) + return ((type(x) == "string") or (type(x) == "integer") or (type(x) == "number") or (sym_3f(x) and not multi_sym_3f(x))) + end local function ast_source(ast) if (table_3f(ast) or sequence_3f(ast)) then return (getmetatable(ast) or {}) @@ -5004,8 +4944,6 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. walk(iterfn, node, k, v) end return nil - else - return nil end end walk((_3fcustom_iterator or pairs), nil, nil, root) @@ -5025,16 +4963,16 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. end return subopts end - local root + local root = nil local function _160_() end - root = {chunk = nil, scope = nil, options = nil, reset = _160_} - root["set-reset"] = function(_161_) - local _arg_162_ = _161_ - local chunk = _arg_162_["chunk"] - local scope = _arg_162_["scope"] - local options = _arg_162_["options"] - local reset = _arg_162_["reset"] + root = {chunk = nil, options = nil, reset = _160_, scope = nil} + root["set-reset"] = function(_161_0) + local _162_ = _161_0 + local chunk = _162_["chunk"] + local options = _162_["options"] + local reset = _162_["reset"] + local scope = _162_["scope"] root.reset = function() root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset return nil @@ -5042,35 +4980,31 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return root.reset end local warned = {} - local function check_plugin_version(_163_) - local _arg_164_ = _163_ - local name = _arg_164_["name"] - local versions = _arg_164_["versions"] - local plugin = _arg_164_ + local function check_plugin_version(_163_0) + local _164_ = _163_0 + local plugin = _164_ + local name = _164_["name"] + local versions = _164_["versions"] if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not warned[plugin]) then warned[plugin] = true return warn(string.format("plugin %s does not support Fennel version %s", (name or "unknown"), version)) - else - return nil end end local function hook_opts(event, _3foptions, ...) - local plugins + local plugins = nil local function _167_(...) - local t_166_ = _3foptions - if (nil ~= t_166_) then - t_166_ = (t_166_).plugins - else + local _166_0 = _3foptions + if (nil ~= _166_0) then + _166_0 = _166_0.plugins end - return t_166_ + return _166_0 end local function _170_(...) - local t_169_ = root.options - if (nil ~= t_169_) then - t_169_ = (t_169_).plugins - else + local _169_0 = root.options + if (nil ~= _169_0) then + _169_0 = _169_0.plugins end - return t_169_ + return _169_0 end plugins = (_167_(...) or _170_(...)) if plugins then @@ -5078,23 +5012,21 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. for _, plugin in ipairs(plugins) do if result then break end check_plugin_version(plugin) - local _172_ = plugin[event] - if (nil ~= _172_) then - local f = _172_ + local _172_0 = plugin[event] + if (nil ~= _172_0) then + local f = _172_0 result = f(...) else - result = nil + result = nil end end return result - else - return nil end end local function hook(event, ...) return hook_opts(event, root.options, ...) end - return {warn = warn, allpairs = allpairs, stablepairs = stablepairs, copy = copy, ["get-in"] = get_in, kvmap = kvmap, map = map, ["walk-tree"] = walk_tree, ["member?"] = member_3f, list = list, sequence = sequence, sym = sym, varg = varg, expr = expr, comment = comment_2a, ["comment?"] = comment_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["multi-sym?"] = multi_sym_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["varg?"] = varg_3f, ["quoted?"] = quoted_3f, ["string?"] = string_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["lua-keywords"] = lua_keywords, hook = hook, ["hook-opts"] = hook_opts, ["propagate-options"] = propagate_options, root = root, ["debug-on?"] = debug_on_3f, ["ast-source"] = ast_source, version = version, ["runtime-version"] = runtime_version, len = len, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";")} + return {["ast-source"] = ast_source, ["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["every?"] = every_3f, ["expr?"] = expr_3f, ["get-in"] = get_in, ["hook-opts"] = hook_opts, ["idempotent-expr?"] = idempotent_expr_3f, ["list?"] = list_3f, ["lua-keywords"] = lua_keywords, ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";"), ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["runtime-version"] = runtime_version, ["sequence?"] = sequence_3f, ["string?"] = string_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, expr = expr, hook = hook, kvmap = kvmap, len = len, list = list, map = map, maxn = maxn, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg, version = version, warn = warn} end utils = require("fennel.utils") local parser = require("fennel.parser") @@ -5107,7 +5039,6 @@ local function eval_env(env, opts) local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}, opts) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](env0) - else end return specials["wrap-env"](env0) else @@ -5118,15 +5049,12 @@ local function eval_opts(options, str) local opts = utils.copy(options) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](opts.env) - else end if (not opts.filename and not opts.source) then opts.source = str - else end if (opts.env == "_COMPILER") then opts.scope = compiler["make-scope"](compiler.scopes.compiler) - else end return opts end @@ -5134,15 +5062,15 @@ local function eval(str, options, ...) local opts = eval_opts(options, str) local env = eval_env(opts.env, opts) local lua_source = compiler["compile-string"](str, opts) - local loader - local function _737_(...) + local loader = nil + local function _709_(...) if opts.filename then return ("@" .. opts.filename) else return str end end - loader = specials["load-code"](lua_source, env, _737_(...)) + loader = specials["load-code"](lua_source, env, _709_(...)) opts.filename = nil return loader(...) end @@ -5155,35 +5083,33 @@ local function dofile_2a(filename, options, ...) return eval(source, opts, ...) end local function syntax() - local body_3f = {"when", "with-open", "collect", "icollect", "fcollect", "lambda", "\206\187", "macro", "match", "matchless", "match-try", "accumulate", "doto"} - local binding_3f = {"collect", "icollect", "fcollect", "each", "for", "let", "with-open", "accumulate"} + local body_3f = {"when", "with-open", "collect", "icollect", "fcollect", "lambda", "\206\187", "macro", "match", "match-try", "case", "case-try", "accumulate", "faccumulate", "doto"} + local binding_3f = {"collect", "icollect", "fcollect", "each", "for", "let", "with-open", "accumulate", "faccumulate"} local define_3f = {"fn", "lambda", "\206\187", "var", "local", "macro", "macros", "global"} local out = {} for k, v in pairs(compiler.scopes.global.specials) do local metadata = (compiler.metadata[v] or {}) - do end (out)[k] = {["special?"] = true, ["body-form?"] = metadata["fnl/body-form?"], ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} + out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = metadata["fnl/body-form?"], ["define?"] = utils["member?"](k, define_3f), ["special?"] = true} end for k, v in pairs(compiler.scopes.global.macros) do - out[k] = {["macro?"] = true, ["body-form?"] = utils["member?"](k, body_3f), ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} + out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = utils["member?"](k, body_3f), ["define?"] = utils["member?"](k, define_3f), ["macro?"] = true} end for k, v in pairs(_G) do - local _738_ = type(v) - if (_738_ == "function") then - out[k] = {["global?"] = true, ["function?"] = true} - elseif (_738_ == "table") then + local _710_0 = type(v) + if (_710_0 == "function") then + out[k] = {["function?"] = true, ["global?"] = true} + elseif (_710_0 == "table") then for k2, v2 in pairs(v) do if (("function" == type(v2)) and (k ~= "_G")) then out[(k .. "." .. k2)] = {["function?"] = true, ["global?"] = true} - else end end out[k] = {["global?"] = true} - else end end return out end -local mod = {list = utils.list, ["list?"] = utils["list?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], ["table?"] = utils["table?"], comment = utils.comment, ["comment?"] = utils["comment?"], varg = utils.varg, ["varg?"] = utils["varg?"], ["sym-char?"] = parser["sym-char?"], parser = parser.parser, compile = compiler.compile, ["compile-string"] = compiler["compile-string"], ["compile-stream"] = compiler["compile-stream"], eval = eval, repl = repl, view = view, dofile = dofile_2a, ["load-code"] = specials["load-code"], doc = specials.doc, metadata = compiler.metadata, traceback = compiler.traceback, version = utils.version, ["runtime-version"] = utils["runtime-version"], ["ast-source"] = utils["ast-source"], path = utils.path, ["macro-path"] = utils["macro-path"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["search-module"] = specials["search-module"], ["make-searcher"] = specials["make-searcher"], searcher = specials["make-searcher"](), syntax = syntax, gensym = compiler.gensym, scope = compiler["make-scope"], mangle = compiler["global-mangling"], unmangle = compiler["global-unmangling"], compile1 = compiler.compile1, ["string-stream"] = parser["string-stream"], granulate = parser.granulate, loadCode = specials["load-code"], make_searcher = specials["make-searcher"], makeSearcher = specials["make-searcher"], searchModule = specials["search-module"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], macroLoaded = specials["macro-loaded"], compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], stringStream = parser["string-stream"], runtimeVersion = utils["runtime-version"]} +local mod = {["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-path"] = utils["macro-path"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["multi-sym?"] = utils["multi-sym?"], ["runtime-version"] = utils["runtime-version"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, runtimeVersion = utils["runtime-version"], scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, syntax = syntax, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = utils.version, view = view} mod.install = function(_3fopts) table.insert((package.searchers or package.loaders), specials["make-searcher"](_3fopts)) return mod @@ -5191,18 +5117,18 @@ end utils["fennel-module"] = mod do local module_name = "fennel.macros" - local _ - local function _741_() + local _ = nil + local function _713_() return mod end - package.preload[module_name] = _741_ + package.preload[module_name] = _713_ _ = nil - local env + local env = nil do - local _742_ = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) - do end (_742_)["utils"] = utils - _742_["fennel"] = mod - env = _742_ + local _714_0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) + _714_0["utils"] = utils + _714_0["fennel"] = mod + env = _714_0 end local built_ins = eval([===[;; These macros are awkward because their definition cannot rely on the any ;; built-in macros, only special forms. (no when, no icollect, etc) @@ -5353,8 +5279,9 @@ do (into iter) (extract-into iter-tbl)] `(let [tbl# ,into] (each ,iter - (match ,kv-expr - (k# v#) (tset tbl# k# v#))) + (let [(k# v#) ,kv-expr] + (if (and (not= k# nil) (not= v# nil)) + (tset tbl# k# v#)))) tbl#))) (fn seq-collect [how iter-tbl value-expr ...] @@ -5615,8 +5542,8 @@ do :macro macro* :macrodebug macrodebug* :import-macros import-macros*} - ]===], {env = env, scope = compiler.scopes.compiler, allowedGlobals = false, useMetadata = true, filename = "src/fennel/macros.fnl", moduleName = module_name}) - local _0 + ]===], {env = env, filename = "src/fennel/macros.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) + local _0 = nil for k, v in pairs(built_ins) do compiler.scopes.global.macros[k] = v end @@ -5625,36 +5552,34 @@ do ;; This is separated out so we can use the "core" macros during the ;; implementation of pattern matching. - (fn without-multival [opts] - (if opts.multival? - (let [copy {}] - (each [k v (pairs opts)] - (tset copy k v)) - (tset copy :multival? nil) - copy) - opts)) + (fn copy [t] (collect [k v (pairs t)] k v)) - (fn match-values [vals pattern unifications match-pattern opts] + (fn with [opts k] + (doto (copy opts) (tset k true))) + + (fn without [opts k] + (doto (copy opts) (tset k nil))) + + (fn case-values [vals pattern unifications case-pattern opts] (let [condition `(and) bindings []] (each [i pat (ipairs pattern)] - (let [(subcondition subbindings) (match-pattern [(. vals i)] pat - unifications (without-multival opts))] + (let [(subcondition subbindings) (case-pattern [(. vals i)] pat + unifications (without opts :multival?))] (table.insert condition subcondition) - (each [_ b (ipairs subbindings)] - (table.insert bindings b)))) + (icollect [_ b (ipairs subbindings) &into bindings] b))) (values condition bindings))) - (fn match-table [val pattern unifications match-pattern opts] + (fn case-table [val pattern unifications case-pattern opts] (let [condition `(and (= (_G.type ,val) :table)) bindings []] (each [k pat (pairs pattern)] (if (= pat `&) (let [rest-pat (. pattern (+ k 1)) rest-val `(select ,k ((or table.unpack _G.unpack) ,val)) - subcondition (match-table `(pick-values 1 ,rest-val) - rest-pat unifications match-pattern - (without-multival opts))] + subcondition (case-table `(pick-values 1 ,rest-val) + rest-pat unifications case-pattern + (without opts :multival?))] (if (not (sym? rest-pat)) (table.insert condition subcondition)) (assert (= nil (. pattern (+ k 2))) @@ -5675,18 +5600,17 @@ do (or (not= :number (type k)) (and (not= `&as (. pattern (- k 1))) (not= `& (. pattern (- k 1))))) (let [subval `(. ,val ,k) - (subcondition subbindings) (match-pattern [subval] pat + (subcondition subbindings) (case-pattern [subval] pat unifications - (without-multival opts))] + (without opts :multival?))] (table.insert condition subcondition) - (each [_ b (ipairs subbindings)] - (table.insert bindings b))))) + (icollect [_ b (ipairs subbindings) &into bindings] b)))) (values condition bindings))) - (fn match-guard [vals condition guards unifications match-pattern opts] + (fn case-guard [vals condition guards unifications case-pattern opts] (if (= 0 (length guards)) - (match-pattern vals condition unifications opts) - (let [(pcondition bindings) (match-pattern vals condition unifications opts) + (case-pattern vals condition unifications opts) + (let [(pcondition bindings) (case-pattern vals condition unifications opts) condition `(and ,(unpack guards))] (values `(and ,pcondition (let ,bindings @@ -5697,8 +5621,8 @@ do (if (list? pattern) (let [result {}] (each [_ child-pattern (ipairs pattern)] - (each [name symbol (pairs (symbols-in-pattern child-pattern))] - (tset result name symbol))) + (collect [name symbol (pairs (symbols-in-pattern child-pattern)) &into result] + name symbol)) result) (sym? pattern) (if (and (not= pattern `or) @@ -5710,14 +5634,14 @@ do (= (type pattern) :table) (let [result {}] (each [key-pattern value-pattern (pairs pattern)] - (each [name symbol (pairs (symbols-in-pattern key-pattern))] - (tset result name symbol)) - (each [name symbol (pairs (symbols-in-pattern value-pattern))] - (tset result name symbol))) + (collect [name symbol (pairs (symbols-in-pattern key-pattern)) &into result] + name symbol) + (collect [name symbol (pairs (symbols-in-pattern value-pattern)) &into result] + name symbol)) result) {})) - (fn symbols-in-every-pattern [pattern-list unification?] + (fn symbols-in-every-pattern [pattern-list infer-unification?] "gives a list of symbols that are present in every pattern in the list" (let [?symbols (accumulate [?symbols nil _ pattern (ipairs pattern-list)] @@ -5730,18 +5654,18 @@ do ?symbols) in-pattern)))] (icollect [_ symbol (pairs (or ?symbols {}))] - (if (not (and unification? (in-scope? symbol))) + (if (not (and infer-unification? + (in-scope? symbol))) symbol)))) - (fn match-or [vals pattern guards unifications match-pattern opts] - ;; if guards is present, this is a (where (or)) shape - (let [bindings (symbols-in-every-pattern [(unpack pattern 2)] opts.unification?)] + (fn case-or [vals pattern guards unifications case-pattern opts] + (let [pattern [(unpack pattern 2)] + bindings (symbols-in-every-pattern pattern opts.infer-unification?)] ;; TODO opts.infer-unification instead of opts.unification? (if (= 0 (length bindings)) ;; no bindings special case generates simple code (let [condition - (fcollect [i 2 (length pattern) &into `(or)] - (let [subpattern (. pattern i) - (subcondition subbindings) (match-pattern vals subpattern unifications opts)] + (icollect [i subpattern (ipairs pattern) &into `(or)] + (let [(subcondition subbindings) (case-pattern vals subpattern unifications opts)] subcondition))] (values (if (= 0 (length guards)) @@ -5750,19 +5674,19 @@ do [])) ;; case with bindings is handled specially, and returns three values instead of two (let [matched? (gensym :matched?) - bindings-two (icollect [_ binding (ipairs bindings)] - (gensym (tostring binding))) - the-actual-body `(if)] - (for [i 2 (length pattern)] - (let [subpattern (. pattern i) - (subcondition subbindings) (match-guard vals subpattern guards {} match-pattern opts)] - (table.insert the-actual-body subcondition) - (table.insert the-actual-body `(let ,subbindings (values true ,(unpack bindings)))))) + bindings-mangled (icollect [_ binding (ipairs bindings)] + (gensym (tostring binding))) + pre-bindings `(if)] + (each [i subpattern (ipairs pattern)] + (let [(subcondition subbindings) (case-guard vals subpattern guards {} case-pattern opts)] + (table.insert pre-bindings subcondition) + (table.insert pre-bindings `(let ,subbindings + (values true ,(unpack bindings)))))) (values matched? - [`(,(unpack bindings)) `(values ,(unpack bindings-two))] - [`(,matched? ,(unpack bindings-two)) the-actual-body]))))) + [`(,(unpack bindings)) `(values ,(unpack bindings-mangled))] + [`(,matched? ,(unpack bindings-mangled)) pre-bindings]))))) - (fn match-pattern [vals pattern unifications opts top-level?] + (fn case-pattern [vals pattern unifications opts top-level?] "Take the AST of values and a single pattern and returns a condition to determine if it matches as well as a list of bindings to introduce for the duration of the body if it does match." @@ -5773,17 +5697,27 @@ do ;; a "bindings", which bind all of the symbols used in a pattern ;; an optional "pre-bindings", which is a list of bindings that happen ;; before the condition and bindings are evaluated. These should only - ;; come from a (match-or). In this case there should be no recursion: - ;; the call stack should be match-condition > match-pattern > match-or + ;; come from a (case-or). In this case there should be no recursion: + ;; the call stack should be case-condition > case-pattern > case-or + ;; + ;; Here are the expected flags in the opts table: + ;; :infer-unification? boolean - if the pattern should guess when to unify (ie, match -> true, case -> false) + ;; :multival? boolean - if the pattern can contain multivals (in order to disallow patterns like [(1 2)]) + ;; :in-where? boolean - if the pattern is surrounded by (where) (where opts into more pattern features) + ;; :legacy-guard-allowed? boolean - if the pattern should allow `(a ? b) patterns ;; we have to assume we're matching against multiple values here until we ;; know we're either in a multi-valued clause (in which case we know the # ;; of vals) or we're not, in which case we only care about the first one. (let [[val] vals] - (if (or (and (sym? pattern) ; unification with outer locals (or nil) - (not= "_" (tostring pattern)) ; never unify _ - (or (and opts.unification? (in-scope? pattern)) (= :nil (tostring pattern)))) - (and (multi-sym? pattern) opts.unification? (in-scope? (. (multi-sym? pattern) 1)))) + (if (and (sym? pattern) + (or (= pattern `nil) + (and opts.infer-unification? + (in-scope? pattern) + (not= pattern `_)) + (and opts.infer-unification? + (multi-sym? pattern) + (in-scope? (. (multi-sym? pattern) 1))))) (values `(= ,val ,pattern) []) ;; unify a local we've seen already (and (sym? pattern) (. unifications (tostring pattern))) @@ -5794,109 +5728,140 @@ do (if (not wildcard?) (tset unifications (tostring pattern) val)) (values (if (or wildcard? (string.find (tostring pattern) "^?")) true `(not= ,(sym :nil) ,val)) [pattern val])) - + ;; opt-in unify with (=) + (and (list? pattern) + (= (. pattern 1) `=) + (sym? (. pattern 2))) + (let [bind (. pattern 2)] + (assert-compile (= 2 (length pattern)) "(=) should take only one argument" pattern) + (assert-compile (not opts.infer-unification?) "(=) cannot be used inside of match" pattern) + (assert-compile opts.in-where? "(=) must be used in (where) patterns" pattern) + (assert-compile (and (sym? bind) (not= bind `nil) "= has to bind to a symbol" bind)) + (values `(= ,val ,bind) [])) ;; where-or clause (and (list? pattern) (= (. pattern 1) `where) (list? (. pattern 2)) (= (. pattern 2 1) `or)) (do (assert-compile top-level? "can't nest (where) pattern" pattern) - (match-or vals (. pattern 2) [(unpack pattern 3)] unifications match-pattern opts)) - ;; or clause - (and (list? pattern) (= (. pattern 1) `or)) - (do - (assert-compile top-level? "can't nest (or) pattern" pattern) - (match-or vals pattern [] unifications match-pattern opts)) + (case-or vals (. pattern 2) [(unpack pattern 3)] unifications case-pattern (with opts :in-where?))) ;; where clause (and (list? pattern) (= (. pattern 1) `where)) (do (assert-compile top-level? "can't nest (where) pattern" pattern) - (match-guard vals (. pattern 2) [(unpack pattern 3)] unifications match-pattern opts)) + (case-guard vals (. pattern 2) [(unpack pattern 3)] unifications case-pattern (with opts :in-where?))) + ;; or clause (not allowed on its own) + (and (list? pattern) (= (. pattern 1) `or)) + (do + (assert-compile top-level? "can't nest (or) pattern" pattern) + ;; This assertion can be removed to make patterns more permissive + (assert-compile false "(or) must be used in (where) patterns" pattern) + (case-or vals pattern [] unifications case-pattern opts)) ;; guard clause (and (list? pattern) (= (. pattern 2) `?)) - (match-guard vals (. pattern 1) [(unpack pattern 3)] unifications match-pattern opts) + (do + (assert-compile opts.legacy-guard-allowed? "legacy guard clause not supported in case" pattern) + (case-guard vals (. pattern 1) [(unpack pattern 3)] unifications case-pattern opts)) ;; multi-valued patterns (represented as lists) (list? pattern) (do (assert-compile opts.multival? "can't nest multi-value destructuring" pattern) - (match-values vals pattern unifications match-pattern opts)) + (case-values vals pattern unifications case-pattern opts)) ;; table patterns (= (type pattern) :table) - (match-table val pattern unifications match-pattern opts) + (case-table val pattern unifications case-pattern opts) ;; literal value (values `(= ,val ,pattern) [])))) - (fn match-condition [vals clauses unification?] + (fn add-pre-bindings [out pre-bindings] + "Decide when to switch from the current `if` AST to a new one" + (if pre-bindings + ;; `out` no longer needs to grow. + ;; Instead, a new tail `if` AST is introduced, which is where the rest of + ;; the clauses will get appended. This way, all future clauses have the + ;; pre-bindings in scope. + (let [tail `(if)] + (table.insert out true) + (table.insert out `(let ,pre-bindings ,tail)) + tail) + ;; otherwise, keep growing the current `if` AST. + out)) + + (fn case-condition [vals clauses match?] "Construct the actual `if` AST for the given match values and clauses." - (when (not= 0 (% (length clauses) 2)) ; treat odd final clause as default - (table.insert clauses (length clauses) (sym "_"))) - (let [out `(if)] - (var tail out) - (for [i 1 (length clauses) 2] + ;; root is the original `if` AST. + ;; out is the `if` AST that is currently being grown. + (let [root `(if)] + (faccumulate [out root + i 1 (length clauses) 2] (let [pattern (. clauses i) body (. clauses (+ i 1)) - (condition bindings pre-bindings) (match-pattern vals pattern {} {:multival? true : unification?} true)] - (when pre-bindings - (if (. tail 2) - (let [newtail `()] - (table.insert tail newtail) - (set tail newtail))) - (let [newtail `(if)] - (tset tail 1 `let) - (tset tail 2 pre-bindings) - (tset tail 3 newtail) - (set tail newtail))) - (table.insert tail condition) - (table.insert tail `(let ,bindings - ,body)))) - out)) + (condition bindings pre-bindings) (case-pattern vals pattern {} + {:multival? true + :infer-unification? match? + :legacy-guard-allowed? match?} + true) + out (add-pre-bindings out pre-bindings)] + ;; grow the `if` AST by one extra condition + (table.insert out condition) + (table.insert out `(let ,bindings + ,body)) + out)) + root)) - (fn count-match-multival [pattern] + (fn count-case-multival [pattern] + "Identify the amount of multival values that a pattern requires." (if (and (list? pattern) (= (. pattern 2) `?)) - (count-match-multival (. pattern 1)) + (count-case-multival (. pattern 1)) (and (list? pattern) (= (. pattern 1) `where)) - (count-match-multival (. pattern 2)) + (count-case-multival (. pattern 2)) (and (list? pattern) (= (. pattern 1) `or)) (accumulate [longest 0 _ child-pattern (ipairs pattern)] - (math.max longest (count-match-multival child-pattern))) + (math.max longest (count-case-multival child-pattern))) (list? pattern) (length pattern) 1)) - (fn match-val-syms [clauses] - "What is the length of the largest multi-valued clause? return a list of that many gensyms." + (fn case-val-syms [clauses] + "What is the length of the largest multi-valued clause? return a list of that + many gensyms." (let [patterns (fcollect [i 1 (length clauses) 2] (. clauses i)) sym-count (accumulate [longest 0 _ pattern (ipairs patterns)] - (math.max longest (count-match-multival pattern)))] + (math.max longest (count-case-multival pattern)))] (fcollect [i 1 sym-count &into (list)] (gensym)))) - (fn match* [val ...] + (fn case-impl [match? val ...] + "The shared implementation of case and match." + (assert (not= val nil) "missing subject") + (assert (= 0 (math.fmod (select :# ...) 2)) + "expected even number of pattern/body pairs") + (assert (not= 0 (select :# ...)) + "expected at least one pattern/body pair") + (let [clauses [...] + vals (case-val-syms clauses)] + ;; protect against multiple evaluation of the value, bind against as + ;; many values as we ever match against in the clauses. + (list `let [vals val] (case-condition vals clauses match?)))) + + (fn case* [val ...] "Perform pattern matching on val. See reference for details. Syntax: - (match data-expression + (case data-expression pattern body (where pattern guards*) body (or pattern patterns*) body (where (or pattern patterns*) guards*) body ;; legacy: (pattern ? guards*) body)" - (assert (not= val nil) "missing subject") - (assert (= 0 (math.fmod (select :# ...) 2)) - "expected even number of pattern/body pairs") - (assert (not= 0 (select :# ...)) - "expected at least one pattern/body pair") - (let [clauses [...] - vals (match-val-syms clauses)] - ;; protect against multiple evaluation of the value, bind against as - ;; many values as we ever match against in the clauses. - (list `let [vals val] (match-condition vals clauses true)))) + (case-impl false val ...)) - (fn matchless* [val ...] - "Perform pattern matching on val, without unifying on variables in local scope. See reference for details. + (fn match* [val ...] + "Perform pattern matching on val, automatically unifying on variables in + local scope. See reference for details. Syntax: @@ -5907,29 +5872,45 @@ do (where (or pattern patterns*) guards*) body ;; legacy: (pattern ? guards*) body)" - (assert (not= val nil) "missing subject") - (assert (= 0 (math.fmod (select :# ...) 2)) - "expected even number of pattern/body pairs") - (assert (not= 0 (select :# ...)) - "expected at least one pattern/body pair") - (let [clauses [...] - vals (match-val-syms clauses)] - ;; protect against multiple evaluation of the value, bind against as - ;; many values as we ever match against in the clauses. - (list `let [vals val] (match-condition vals clauses false)))) + (case-impl true val ...)) - (fn match-try-step [expr else pattern body ...] + (fn case-try-step [how expr else pattern body ...] (if (= nil pattern body) expr ;; unlike regular match, we can't know how many values the value ;; might evaluate to, so we have to capture them all in ... via IIFE ;; to avoid double-evaluation. `((fn [...] - (match ... - ,pattern ,(match-try-step body else ...) + (,how ... + ,pattern ,(case-try-step how body else ...) ,(unpack else))) ,expr))) + (fn case-try-impl [how expr pattern body ...] + (let [clauses [pattern body ...] + last (. clauses (length clauses)) + catch (if (= `catch (and (= :table (type last)) (. last 1))) + (let [[_ & e] (table.remove clauses)] e) ; remove `catch sym + [`_# `...])] + (assert (= 0 (math.fmod (length clauses) 2)) + "expected every pattern to have a body") + (assert (= 0 (math.fmod (length catch) 2)) + "expected every catch pattern to have a body") + (case-try-step how expr catch (unpack clauses)))) + + (fn case-try* [expr pattern body ...] + "Perform chained pattern matching for a sequence of steps which might fail. + + The values from the initial expression are matched against the first pattern. + If they match, the first body is evaluated and its values are matched against + the second pattern, etc. + + If there is a (catch pat1 body1 pat2 body2 ...) form at the end, any mismatch + from the steps will be tried against these patterns in sequence as a fallback + just like a normal match. If there is no catch, the mismatched values will be + returned as the value of the entire expression." + (case-try-impl `case expr pattern body ...)) + (fn match-try* [expr pattern body ...] "Perform chained pattern matching for a sequence of steps which might fail. @@ -5941,21 +5922,13 @@ do from the steps will be tried against these patterns in sequence as a fallback just like a normal match. If there is no catch, the mismatched values will be returned as the value of the entire expression." - (let [clauses [pattern body ...] - last (. clauses (length clauses)) - catch (if (= `catch (and (= :table (type last)) (. last 1))) - (let [[_ & e] (table.remove clauses)] e) ; remove `catch sym - [`_# `...])] - (assert (= 0 (math.fmod (length clauses) 2)) - "expected every pattern to have a body") - (assert (= 0 (math.fmod (length catch) 2)) - "expected every catch pattern to have a body") - (match-try-step expr catch (unpack clauses)))) + (case-try-impl `match expr pattern body ...)) - {:match match* - :matchless matchless* + {:case case* + :case-try case-try* + :match match* :match-try match-try*} - ]===], {env = env, scope = compiler.scopes.compiler, allowedGlobals = false, useMetadata = true, filename = "src/fennel/match.fnl", moduleName = module_name}) + ]===], {allowedGlobals = false, env = env, filename = "src/fennel/match.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) for k, v in pairs(match_macros) do compiler.scopes.global.macros[k] = v end diff --git a/test/diagnostic-test.fnl b/test/diagnostic-test.fnl index fd7bcd2..a9f80f7 100644 --- a/test/diagnostic-test.fnl +++ b/test/diagnostic-test.fnl @@ -31,7 +31,7 @@ [{:params {: diagnostics}}] (find [i v (ipairs diagnostics)] (match v - {:message "tried to reference a special form at runtime" + {:message "tried to reference a special form without calling it" :range {:start {:character 4 :line 0} :end {:character 6 :line 0}}} v)))]