Inline-Lua
view release on metacpan or search on metacpan
ffi/fennel.lua view on Meta::CPAN
-- SPDX-License-Identifier: MIT
-- SPDX-FileCopyrightText: Calvin Rose and contributors
package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
local _710_ = require("fennel.utils")
local utils = _710_
local copy = _710_["copy"]
local parser = require("fennel.parser")
local compiler = require("fennel.compiler")
local specials = require("fennel.specials")
local view = require("fennel.view")
local depth = 0
local function prompt_for(top_3f)
if top_3f then
return (string.rep(">", (depth + 1)) .. " ")
else
return (string.rep(".", (depth + 1)) .. " ")
end
end
local function default_read_chunk(parser_state)
io.write(prompt_for((0 == parser_state["stack-size"])))
io.flush()
local _712_0 = io.read()
if (nil ~= _712_0) then
local input = _712_0
return (input .. "\n")
end
end
local function default_on_values(xs)
io.write(table.concat(xs, "\9"))
return io.write("\n")
end
local function default_on_error(errtype, err)
local function _715_()
local _714_0 = errtype
if (_714_0 == "Runtime") then
return (compiler.traceback(tostring(err), 4) .. "\n")
else
local _ = _714_0
return ("%s error: %s\n"):format(errtype, tostring(err))
end
end
return io.write(_715_())
end
local function splice_save_locals(env, lua_source, scope)
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___[%q]"):format((scope.manglings[name] or name), name)
if (nil ~= val_19_) then
i_18_ = (i_18_ + 1)
tbl_17_[i_18_] = val_19_
end
end
saves = tbl_17_
end
local binds = nil
do
local tbl_17_ = {}
local i_18_ = #tbl_17_
for raw, name in pairs(scope.manglings) do
local val_19_ = nil
if not scope.gensyms[name] then
val_19_ = ("___replLocals___[%q] = %s"):format(raw, name)
else
val_19_ = nil
end
if (nil ~= val_19_) then
i_18_ = (i_18_ + 1)
ffi/fennel.lua view on Meta::CPAN
local function _840_(...)
local src0 = nil
if save_locals_3f then
src0 = splice_save_locals(env, src, opts.scope)
else
src0 = src
end
return pcall(specials["load-code"], src0, env)
end
return _833_(_840_(...))
elseif ((_831_0 == false) and (nil ~= _832_0)) then
local msg = _832_0
clear_stream()
return callbacks.onError("Compile", msg)
end
end
local function _842_()
opts["source"] = src_string
return opts
end
_830_(pcall(compiler.compile, form, _842_()))
utils.root.options = old_root_options
if exit_next_3f then
return env.___replLocals___["*1"]
else
return loop()
end
end
end
end
local value = loop()
depth = (depth - 1)
if readline then
readline.save_history()
end
if opts.exit then
opts.exit(opts, depth)
end
return value
end
local repl_mt = {__index = {repl = repl}}
repl_mt.__call = function(_848_0, _3fopts)
local _849_ = _848_0
local overrides = _849_
local view_opts = _849_["view-opts"]
local opts = copy(_3fopts, copy(overrides))
local _851_
do
local _850_0 = _3fopts
if (nil ~= _850_0) then
_850_0 = _850_0["view-opts"]
end
_851_ = _850_0
end
opts["view-opts"] = copy(_851_, copy(view_opts))
return repl(opts)
end
return setmetatable({["view-opts"] = {}}, repl_mt)
end
package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...)
local _484_ = require("fennel.utils")
local utils = _484_
local pack = _484_["pack"]
local unpack = _484_["unpack"]
local view = require("fennel.view")
local parser = require("fennel.parser")
local compiler = require("fennel.compiler")
local SPECIALS = compiler.scopes.global.specials
local function str1(x)
return tostring(x[1])
end
local function wrap_env(env)
local function _485_(_, key)
if utils["string?"](key) then
return env[compiler["global-unmangling"](key)]
else
return env[key]
end
end
local function _487_(_, key, value)
if utils["string?"](key) then
env[compiler["global-unmangling"](key)] = value
return nil
else
env[key] = value
return nil
end
end
local function _489_()
local _490_
do
local tbl_14_ = {}
for k, v in utils.stablepairs(env) do
local k_15_, v_16_ = nil, nil
local _491_
if utils["string?"](k) then
_491_ = compiler["global-unmangling"](k)
else
_491_ = k
end
k_15_, v_16_ = _491_, v
if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
tbl_14_[k_15_] = v_16_
end
end
_490_ = tbl_14_
end
return next, _490_, nil
end
return setmetatable({}, {__index = _485_, __newindex = _487_, __pairs = _489_})
end
local function fennel_module_name()
return (utils.root.options.moduleName or "fennel")
end
local function current_global_names(_3fenv)
local mt = nil
do
local _494_0 = getmetatable(_3fenv)
if ((_G.type(_494_0) == "table") and (nil ~= _494_0.__pairs)) then
local mtpairs = _494_0.__pairs
local tbl_14_ = {}
for k, v in mtpairs(_3fenv) 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
ffi/fennel.lua view on Meta::CPAN
return add_macros(macro_tbl, ast, scope)
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.")
SPECIALS["tail!"] = function(ast, scope, parent, opts)
compiler.assert((#ast == 2), "Expected one argument", ast)
local call = utils["list?"](compiler.macroexpand(ast[2], scope))
local callee = tostring((call and utils["sym?"](call[1])))
compiler.assert((call and not scope.specials[callee]), "Expected a function call as argument", ast)
compiler.assert(opts.tail, "Must be in tail position", ast)
return compiler.compile1(call, scope, parent, opts)
end
doc_special("tail!", {"body"}, "Assert that the body being called is in tail position.")
SPECIALS["pick-values"] = function(ast, scope, parent)
local n = ast[2]
local vals = utils.list(utils.sym("values"), unpack(ast, 3))
compiler.assert((("number" == type(n)) and (0 <= n) and (n == math.floor(n))), ("Expected n to be an integer >= 0, got " .. tostring(n)))
if (1 == n) then
local _706_ = compiler.compile1(vals, scope, parent, {nval = 1})
local _707_ = _706_[1]
local expr = _707_[1]
return {("(" .. expr .. ")")}
elseif (0 == n) then
for i = 3, #ast do
compiler["keep-side-effects"](compiler.compile1(ast[i], scope, parent, {nval = 0}), parent, nil, ast[i])
end
return {}
else
local syms = nil
do
local tbl_17_ = utils.list()
local i_18_ = #tbl_17_
for _ = 1, n do
local val_19_ = utils.sym(compiler.gensym(scope, "pv"))
if (nil ~= val_19_) then
i_18_ = (i_18_ + 1)
tbl_17_[i_18_] = val_19_
end
end
syms = tbl_17_
end
compiler.destructure(syms, vals, ast, scope, parent, {declaration = true, nomulti = true, noundef = true, symtype = "pv"})
return syms
end
end
doc_special("pick-values", {"n", "..."}, "Evaluate to exactly n values.\n\nFor example,\n (pick-values 2 ...)\nexpands to\n (let [(_0_ _1_) ...]\n (values _0_ _1_))")
SPECIALS["eval-compiler"] = function(ast, scope, parent)
local old_first = ast[1]
ast[1] = utils.sym("do")
local val = eval_compiler_2a(ast, scope, parent)
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)
SPECIALS.unquote = function(ast)
return compiler.assert(false, "tried to use unquote outside quote", ast)
end
doc_special("unquote", {"..."}, "Evaluate the argument even if it's in a quoted form.")
return {["current-global-names"] = current_global_names, ["get-function-metadata"] = get_function_metadata, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env...
end
package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or function(...)
local _281_ = require("fennel.utils")
local utils = _281_
local unpack = _281_["unpack"]
local parser = require("fennel.parser")
local friend = require("fennel.friend")
local view = require("fennel.view")
local scopes = {compiler = nil, global = nil, macro = nil}
local function make_scope(_3fparent)
local parent = (_3fparent or scopes.global)
local _282_
if parent then
_282_ = ((parent.depth or 0) + 1)
else
_282_ = 0
end
return {["gensym-base"] = setmetatable({}, {__index = (parent and parent["gensym-base"])}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), depth = _282_, gensyms = setmetatable({}, {__index = (parent and parent.gensy...
end
local function assert_msg(ast, msg)
local ast_tbl = nil
if ("table" == type(ast)) then
ast_tbl = ast
else
ast_tbl = {}
end
local m = getmetatable(ast)
local filename = ((m and m.filename) or ast_tbl.filename or "unknown")
local line = ((m and m.line) or ast_tbl.line or "?")
local col = ((m and m.col) or ast_tbl.col or "?")
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, _3ffallback_ast)
if not condition then
local _285_ = (utils.root.options or {})
local error_pinpoint = _285_["error-pinpoint"]
local source = _285_["source"]
local unfriendly = _285_["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 then
error(assert_msg(ast0, msg), 0)
else
friend["assert-compile"](condition, msg, ast0, source, {["error-pinpoint"] = error_pinpoint})
end
end
end
return condition
end
scopes.global = make_scope()
scopes.global.vararg = true
scopes.compiler = make_scope(scopes.global)
scopes.macro = scopes.global
local serialize_subst_digits = {["\\10"] = "\\n", ["\\11"] = "\\v", ["\\12"] = "\\f", ["\\13"] = "\\r", ["\\7"] = "\\a", ["\\8"] = "\\b", ["\\9"] = "\\t"}
local function serialize_string(str)
local function _290_(_241)
return ("\\" .. _241:byte())
end
return string.gsub(string.gsub(string.gsub(string.format("%q", str), "\\\n", "\\n"), "\\..?", serialize_subst_digits), "[\128-\255]", _290_)
end
local function global_mangling(str)
ffi/fennel.lua view on Meta::CPAN
destructure_sym(next_sym, {utils.expr(tostring(s))}, left)
else
local key = nil
if (type(k) == "string") then
key = serialize_string(k)
else
key = k
end
local subexpr = utils.expr(("%s[%s]"):format(s, key), "expression")
if (type(k) == "string") then
table.insert(excluded_keys, k)
end
destructure1(v, subexpr, left)
end
end
end
return nil
end
end
local function destructure1(left, rightexprs, up1, top_3f)
if (utils["sym?"](left) and (left[1] ~= "nil")) then
destructure_sym(left, rightexprs, up1, top_3f)
elseif utils["table?"](left) then
destructure_table(left, rightexprs, top_3f, destructure1, up1)
elseif utils["call-of?"](left, ".") then
destructure_values({left}, rightexprs, up1, destructure1)
elseif utils["list?"](left) then
assert_compile(top_3f, "can't nest multi-value destructuring", left)
destructure_values(left, rightexprs, up1, destructure1, true)
else
assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1))
end
return (top_3f and {returned = true})
end
local ret = destructure1(to, from, ast, true)
utils.hook("destructure", from, to, scope, opts0)
apply_deferred_scope_changes(scope, deferred_scope_changes, ast)
return ret
end
local function require_include(ast, scope, parent, opts)
opts.fallback = function(e, no_warn)
if not no_warn then
utils.warn(("include module not found, falling back to require: %s"):format(tostring(e)), ast)
end
return utils.expr(string.format("require(%s)", tostring(e)), "statement")
end
return scopes.global.specials.include(ast, scope, parent, opts)
end
local function compile_asts(asts, options)
local opts = utils.copy(options)
local scope = nil
if ("_COMPILER" == opts.scope) then
scope = scopes.compiler
elseif opts.scope then
scope = opts.scope
else
scope = make_scope(scopes.global)
end
local chunk = {}
if opts.requireAsInclude then
scope.specials.require = require_include
end
if opts.assertAsRepl then
scope.macros.assert = scope.macros["assert-repl"]
end
local _445_ = utils.root
_445_["set-reset"](_445_)
utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
for i = 1, #asts do
local exprs = compile1(asts[i], scope, chunk, {nval = (((i < #asts) and 0) or nil), tail = (i == #asts)})
keep_side_effects(exprs, chunk, nil, asts[i])
if (i == #asts) then
utils.hook("chunk", asts[i], scope)
end
end
utils.root.reset()
return flatten(chunk, opts)
end
local function compile_stream(stream, _3fopts)
local opts = (_3fopts or {})
local asts = nil
do
local tbl_17_ = {}
local i_18_ = #tbl_17_
for _, ast in parser.parser(stream, opts.filename, opts) do
local val_19_ = ast
if (nil ~= val_19_) then
i_18_ = (i_18_ + 1)
tbl_17_[i_18_] = val_19_
end
end
asts = tbl_17_
end
return compile_asts(asts, opts)
end
local function compile_string(str, _3fopts)
return compile_stream(parser["string-stream"](str, _3fopts), _3fopts)
end
local function compile(from, _3fopts)
local _448_0 = type(from)
if (_448_0 == "userdata") then
local function _449_()
local _450_0 = from:read(1)
if (nil ~= _450_0) then
return _450_0:byte()
else
return _450_0
end
end
return compile_stream(_449_, _3fopts)
elseif (_448_0 == "function") then
return compile_stream(from, _3fopts)
else
local _ = _448_0
return compile_asts({from}, _3fopts)
end
end
local function traceback_frame(info)
if ((info.what == "C") and info.name) then
return string.format("\9[C]: in function '%s'", info.name)
elseif (info.what == "C") then
ffi/fennel.lua view on Meta::CPAN
filename = string.format("%q", form.filename)
else
filename = "nil"
end
local symstr = tostring(form)
assert_compile(not runtime_3f, "symbols may only be used at compile time", form)
if (symstr:find("#$") or symstr:find("#[:.]")) then
return string.format("_G.sym('%s', {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil"))
else
return string.format("_G.sym('%s', {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil"))
end
elseif utils["call-of?"](form, "unquote") then
local res = unpack(compile1(form[2], scope, parent))
return res[1]
elseif utils["list?"](form) then
local mapped = quote_all(form, true)
local filename = nil
if form.filename then
filename = string.format("%q", form.filename)
else
filename = "nil"
end
assert_compile(not runtime_3f, "lists may only be used at compile time", form)
return string.format(("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(_G.list()))"), filename, (form.line or "nil"), (form.bytestart or "nil"), mixed_concat(mapped, ", "))
elseif utils["sequence?"](form) then
local mapped_str = mixed_concat(quote_all(form), ", ")
local source = getmetatable(form)
local filename = nil
if source.filename then
filename = ("%q"):format(source.filename)
else
filename = "nil"
end
if runtime_3f then
return string.format("{%s}", mapped_str)
else
return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mapped_str, filename, (source.line or "nil"), "(getmetatable(_G.sequence()))['sequence']")
end
elseif (type(form) == "table") then
local source = getmetatable(form)
local filename = nil
if source.filename then
filename = string.format("%q", source.filename)
else
filename = "nil"
end
local function _482_()
if source then
return source.line
else
return "nil"
end
end
return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(quote_all(form), ", "), filename, _482_())
elseif (type(form) == "string") then
return serialize_string(form)
else
return tostring(form)
end
end
return {["apply-deferred-scope-changes"] = apply_deferred_scope_changes, ["check-binding-valid"] = check_binding_valid, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["declare-local"] = declare_local, ["do-quote"] = do_q...
end
package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...)
local _193_ = require("fennel.utils")
local utils = _193_
local unpack = _193_["unpack"]
local utf8_ok_3f, utf8 = pcall(require, "utf8")
local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't introduce (.*) here"] = {"declaring the local at the top-level"}, ["can't start multisym segment...
local function suggest(msg)
local s = nil
for pat, sug in pairs(suggestions) do
if s then break end
local matches = {msg:match(pat)}
if next(matches) then
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
end
s = tbl_17_
else
s = nil
end
end
return s
end
local function read_line(filename, line, _3fsource)
if _3fsource then
local matcher = string.gmatch((_3fsource .. "\n"), "(.-)(\13?\n)")
for _ = 2, line do
matcher()
end
return matcher()
else
local f = assert(_G.io.open(filename))
local function close_handlers_10_(ok_11_, ...)
f:close()
if ok_11_ then
return ...
else
return error(..., 0)
end
end
local function _197_()
for _ = 2, line do
f:read()
end
return f:read()
end
return close_handlers_10_(_G.xpcall(_197_, (package.loaded.fennel or debug).traceback))
end
end
local function sub(str, start, _end)
if ((_end < start) or (#str < start)) 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))
else
return string.sub(str, start, math.min(_end, str:len()))
end
ffi/fennel.lua view on Meta::CPAN
return codeline
else
local _200_ = (opts or {})
local error_pinpoint = _200_["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 _202_ = (error_pinpoint or {"\27[7m", "\27[0m"})
local open = _202_[1]
local close = _202_[2]
return (sub(codeline, 1, col) .. open .. sub(codeline, (col + 1), (endcol + 1)) .. close .. sub(codeline, (endcol + 2), eol))
end
end
local function friendly_msg(msg, _204_0, source, opts)
local _205_ = _204_0
local col = _205_["col"]
local endcol = _205_["endcol"]
local endline = _205_["endline"]
local filename = _205_["filename"]
local line = _205_["line"]
local ok, codeline = pcall(read_line, filename, line, source)
local endcol0 = nil
if (ok and codeline and (line ~= endline)) then
endcol0 = #codeline
else
endcol0 = endcol
end
local out = {msg, ""}
if (ok and codeline) then
if col then
table.insert(out, highlight_line(codeline, col, endcol0, opts))
else
table.insert(out, codeline)
end
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, opts)
if not condition then
local _209_ = utils["ast-source"](ast)
local col = _209_["col"]
local filename = _209_["filename"]
local line = _209_["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, 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
package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(...)
local _192_ = require("fennel.utils")
local utils = _192_
local unpack = _192_["unpack"]
local friend = require("fennel.friend")
local function granulate(getchunk)
local c, index, done_3f = "", 1, false
local function _211_(parser_state)
if not done_3f then
if (index <= #c) then
local b = c:byte(index)
index = (index + 1)
return b
else
local _212_0 = getchunk(parser_state)
if (nil ~= _212_0) then
local input = _212_0
c, index = input, 2
return c:byte()
else
local _ = _212_0
done_3f = true
return nil
end
end
end
end
local function _216_()
c = ""
return nil
end
return _211_, _216_
end
local function string_stream(str, _3foptions)
local str0 = str:gsub("^#!", ";;")
if _3foptions then
_3foptions.source = str0
end
local index = 1
local function _218_()
local r = str0:byte(index)
index = (index + 1)
return r
end
return _218_
end
local delims = {[123] = 125, [125] = true, [40] = 41, [41] = true, [91] = 93, [93] = true}
local function sym_char_3f(b)
local b0 = nil
if ("number" == type(b)) then
b0 = b
else
b0 = string.byte(b)
end
return ((32 < b0) and not delims[b0] and (b0 ~= 127) and (b0 ~= 34) and (b0 ~= 39) and (b0 ~= 126) and (b0 ~= 59) and (b0 ~= 44) and (b0 ~= 64) and (b0 ~= 96))
end
local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"}
local nan, negative_nan = nil, nil
if (45 == string.byte(tostring((0 / 0)))) then
nan, negative_nan = ( - (0 / 0)), (0 / 0)
else
nan, negative_nan = (0 / 0), ( - (0 / 0))
end
local function char_starter_3f(b)
return (((1 < b) and (b < 127)) or ((192 < b) and (b < 247)))
ffi/fennel.lua view on Meta::CPAN
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
for k, v in pairs(overrides) do
defaults[k] = v
end
return defaults
end
local function _99_(x, options, indent, colon_3f)
local indent0 = (indent or 0)
local options0 = (options or make_options(x))
local x0 = nil
if options0.preprocess then
x0 = options0.preprocess(x, options0)
else
x0 = x
end
local tv = type(x0)
local function _102_()
local _101_0 = getmetatable(x0)
if ((_G.type(_101_0) == "table") and true) then
local __fennelview = _101_0.__fennelview
return __fennelview
end
end
if ((tv == "table") or ((tv == "userdata") and _102_())) then
return pp_table(x0, options0, indent0)
elseif (tv == "number") then
return number__3estring(x0, options0)
else
local function _104_()
if (colon_3f ~= nil) then
return colon_3f
elseif ("function" == type(options0["prefer-colon?"])) then
return options0["prefer-colon?"](x0)
else
return getopt(options0, "prefer-colon?")
end
end
if ((tv == "string") and colon_string_3f(x0) and _104_()) then
return (":" .. x0)
elseif (tv == "string") then
return pp_string(x0, options0, indent0)
elseif ((tv == "boolean") or (tv == "nil")) then
return tostring(x0)
else
return ("#<" .. tostring(x0) .. ">")
end
end
end
pp = _99_
local function _view(x, _3foptions)
return pp(x, make_options(x, _3foptions), 0)
end
return _view
end
package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...)
local view = require("fennel.view")
local version = "1.5.3"
local unpack = (table.unpack or _G.unpack)
local pack = nil
local function _106_(...)
local _107_0 = {...}
_107_0["n"] = select("#", ...)
return _107_0
end
pack = (table.pack or _106_)
local maxn = nil
local function _108_(_241)
local max = 0
for k in pairs(_241) do
if (("number" == type(k)) and (max < k)) then
max = k
else
max = max
end
end
return max
end
maxn = (table.maxn or _108_)
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 = nil
if (_G.jit.os == "OSX") then
jit_os = "macOS"
else
jit_os = _G.jit.os
end
return (_G.jit.version .. " " .. jit_os .. "/" .. _G.jit.arch)
end
local function fengari_vm_3f()
return ((nil ~= _G.fengari) and (type(_G.fengari) == "table") and (nil ~= _G.fengari.VERSION) and (type(_G.fengari.VERSION_NUM) == "number"))
end
local function fengari_vm_version()
return (_G.fengari.RELEASE .. " (" .. _VERSION .. ")")
end
local function lua_vm_version()
if luajit_vm_3f() then
return luajit_vm_version()
elseif fengari_vm_3f() then
return fengari_vm_version()
else
return ("PUC " .. _VERSION)
end
end
local function runtime_version(_3fas_table)
if _3fas_table then
return {fennel = version, lua = lua_vm_version()}
else
return ("Fennel " .. version .. " on " .. lua_vm_version())
end
end
local len = nil
do
local _113_0, _114_0 = pcall(require, "utf8")
if ((_113_0 == true) and (nil ~= _114_0)) then
ffi/fennel.lua view on Meta::CPAN
if (_3ffilename and _3fline) then
loc = (_3ffilename .. ":" .. _3fline .. ": ")
else
loc = ""
end
end
end
return (_G.io.stderr):write(("--WARNING: %s%s\n"):format(loc, msg))
end
end
end
local warned = {}
local function check_plugin_version(_180_0)
local _181_ = _180_0
local plugin = _181_
local name = _181_["name"]
local versions = _181_["versions"]
if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not (string_3f(versions) and version:find(versions)) and not warned[plugin]) then
warned[plugin] = true
return warn(string.format("plugin %s does not support Fennel version %s", (name or "unknown"), version))
end
end
local function hook_opts(event, _3foptions, ...)
local plugins = nil
local function _184_(...)
local _183_0 = _3foptions
if (nil ~= _183_0) then
_183_0 = _183_0.plugins
end
return _183_0
end
local function _187_(...)
local _186_0 = root.options
if (nil ~= _186_0) then
_186_0 = _186_0.plugins
end
return _186_0
end
plugins = (_184_(...) or _187_(...))
if plugins then
local result = nil
for _, plugin in ipairs(plugins) do
if (nil ~= result) then break end
check_plugin_version(plugin)
local _189_0 = plugin[event]
if (nil ~= _189_0) then
local f = _189_0
result = f(...)
else
result = nil
end
end
return result
end
end
local function hook(event, ...)
return hook_opts(event, root.options, ...)
end
return {["ast-source"] = ast_source, ["call-of?"] = call_of_3f, ["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["every?"] = every_3f, ["expr?"] = expr_3f, ["fennel-module"] = nil, ["get-in"] = get_in, ["hook-opts"] = hook_opts, ["idempoten...
end
utils = require("fennel.utils")
local parser = require("fennel.parser")
local compiler = require("fennel.compiler")
local specials = require("fennel.specials")
local repl = require("fennel.repl")
local view = require("fennel.view")
local function eval_env(env, opts)
if (env == "_COMPILER") then
local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}, opts)
if (opts.allowedGlobals == nil) then
opts.allowedGlobals = specials["current-global-names"](env0)
end
return specials["wrap-env"](env0)
else
return (env and specials["wrap-env"](env))
end
end
local function eval_opts(options, str)
local opts = utils.copy(options)
if (opts.allowedGlobals == nil) then
opts.allowedGlobals = specials["current-global-names"](opts.env)
end
if (not opts.filename and not opts.source) then
opts.source = str
end
if (opts.env == "_COMPILER") then
opts.scope = compiler["make-scope"](compiler.scopes.compiler)
end
return opts
end
local function eval(str, _3foptions, ...)
local opts = eval_opts(_3foptions, str)
local env = eval_env(opts.env, opts)
local lua_source = compiler["compile-string"](str, opts)
local loader = nil
local function _858_(...)
if opts.filename then
return ("@" .. opts.filename)
else
return str
end
end
loader = specials["load-code"](lua_source, env, _858_(...))
opts.filename = nil
return loader(...)
end
local function dofile_2a(filename, _3foptions, ...)
local opts = utils.copy(_3foptions)
local f = assert(io.open(filename, "rb"))
local source = assert(f:read("*all"), ("Could not read " .. filename))
f:close()
opts.filename = filename
return eval(source, opts, ...)
end
local function syntax()
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 deprecated = {"~=", "#", "global", "require-macros", "pick-args"}
local out = {}
for k, v in pairs(compiler.scopes.global.specials) do
local metadata = (compiler.metadata[v] or {})
out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = metadata["fnl/body-form?"], ["define?"] = utils["member?"](k, define_3f), ["deprecated?"] = utils["member?"](k, deprecated), ["special?"] = true}
end
for k in pairs(compiler.scopes.global.macros) do
out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = utils["member?"](k, body_3f), ["define?"] = utils["member?"](k, define_3f), ["macro?"] = true}
( run in 4.131 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )