diff --git a/editor/imstate.fnl b/editor/imstate.fnl index bbbcafa..be539d5 100644 --- a/editor/imstate.fnl +++ b/editor/imstate.fnl @@ -155,11 +155,13 @@ (fn textbox [view tag text x y w] (var textNew (or text "")) - (local (h hText xText yText) (values 20 16 (+ x 2) (+ y 2))) + (local (h hText xText yText) (values (+ (style.font:get_height) 4) (style.font:get_height) (+ x 2) (+ y 2))) ; handle key events (when (focus view tag x y w h {:i 1 :iAnchor 1 :blink (love.timer.getTime)}) (local f view.imstate.focus) + (when (> f.i (+ (length text) 1)) (set f.i (+ (length text) 1))) + (when (> f.iAnchor (+ (length text) 1)) (set f.iAnchor (+ (length text) 1))) (when view.imstate.text (set textNew (replace-selection view textNew view.imstate.text))) (each [_ key (ipairs (or view.imstate.keys []))] diff --git a/editor/init.fnl b/editor/init.fnl index e56be3d..4c5f423 100644 --- a/editor/init.fnl +++ b/editor/init.fnl @@ -57,6 +57,22 @@ "ctrl+v" "tileedit:paste" }) +(command.add :editor.replview { + "repl:submit" #(core.active_view:submit) +}) + +(local ReplView (require :editor.replview)) +(local repl (require :editor.repl)) +(command.add nil { + "repl:create" (fn [] + (local node (core.root_view:get_active_node)) + (node:add_view (ReplView (repl.new))) + ) +}) +(keymap.add { + :return "repl:submit" +}) + (fn inline-eval [eval] (let [ldoc core.active_view.doc (aline acol bline bcol) (ldoc:get_selection) diff --git a/editor/repl.fnl b/editor/repl.fnl new file mode 100644 index 0000000..90cd3f1 --- /dev/null +++ b/editor/repl.fnl @@ -0,0 +1,49 @@ +(local util (require :lib.util)) +(local fennel (require :lib.fennel)) +(local style (require :core.style)) +(local lume (require :lib.lume)) +(local {: textbutton} (util.require :editor.imstate)) +(local {: inspect} (util.require :inspector)) +(local repl (util.hot-table ...)) + +(fn repl.inspector [{: vals : states} view x y] + (var h 0) + (each [i v (ipairs vals)] + (set h (+ h (inspect (. states i) v view x (+ y h) view.size.x)))) + (+ h style.padding.y)) + +(fn repl.notify [listeners line] + (each [_ listener (ipairs listeners)] + (listener:append line))) + +(fn repl.mk-result [vals] + (local inspector #(repl.inspector $...)) + {:draw inspector : vals :states (icollect [_ (ipairs vals)] {})}) + +(fn repl.run [{: listeners}] + (fennel.repl {:readChunk coroutine.yield + :onValues #(repl.notify listeners (repl.mk-result $1)) + :onError (fn [errType err luaSource] (repl.notify listeners (repl.mk-result [err]))) + :pp #$1 + :env (lume.clone _G)})) + +(fn repl.listen [{: listeners} listener] + (table.insert listeners listener)) + +(fn repl.unlisten [{: listeners} listener] + (lume.remove listeners listener)) + +(fn repl.submit [{: coro} chunk] + (coroutine.resume coro (.. chunk "\n"))) + +(fn repl.new [] + (local result + {:listeners [] + :listen #(repl.listen $...) + :unlisten #(repl.unlisten $...) + :submit #(repl.submit $...) + :coro (coroutine.create repl.run)}) + (coroutine.resume result.coro result) + result) + +repl.hot diff --git a/editor/replview.fnl b/editor/replview.fnl new file mode 100644 index 0000000..f7a2e6c --- /dev/null +++ b/editor/replview.fnl @@ -0,0 +1,61 @@ +(local util (require :lib.util)) +(local {: attach-imstate : textbox} (util.require :editor.imstate)) +(local View (require :core.view)) +(local style (require :core.style)) + +(local ReplView (View:extend)) + +(fn ReplView.new [self conn] + (ReplView.super.new self) + (attach-imstate self) + (set self.conn conn) + (set self.log []) + (set self.cmd "") + (set self.scrollheight math.huge) + (set self.scrollable true) + (self.conn:listen self)) + +(fn ReplView.try_close [self do_close] + (self.conn:unlisten self) + (ReplView.super.try_close self do_close)) + +(fn ReplView.get_scrollable_size [self] self.scrollheight) + +(fn ReplView.append [self line] + (table.insert self.log line)) + +(fn ReplView.draw-cmd [{: cmd} view x y] + (renderer.draw_text style.font cmd x y style.text) + (+ (style.font:get_height) style.padding.y)) + +(fn ReplView.submit [self ?cmd] + (local cmd (or ?cmd self.cmd)) + (when (= ?cmd nil) + (set self.cmd "")) + (self:append {:draw #(self.draw-cmd $...) : cmd}) + (self.conn:submit cmd)) + +(fn ReplView.draw [self] + (self:draw_background style.background) + (self:draw_scrollbar) + (var x (- self.position.x self.scroll.x)) + (var y (- self.position.y self.scroll.y)) + (var rendered-h 0) + + ; todo: cache sizes and avoid drawing if offscreen? + ; note: then offscreen items can't be focussed without further effort + ; todo: draw line numbers + (each [i line (ipairs self.log)] + (let [h (line:draw self x y)] + (set y (+ y h)) + (set rendered-h (+ rendered-h h)))) + + (set self.cmd (textbox self :command self.cmd x y self.size.x)) + + (local pin-to-bottom (>= self.scroll.to.y (- self.scrollheight self.size.y))) + (set self.scrollheight (+ rendered-h (style.font:get_height) 4)) + (when pin-to-bottom + (set self.scroll.to.y (- self.scrollheight self.size.y)))) + +ReplView + diff --git a/game/tiles.json b/game/tiles.json index 9708932..46357cb 100644 --- a/game/tiles.json +++ b/game/tiles.json @@ -1 +1 @@ -[{"gfx":"8080808080808080808080808080808080808080808080808080808080808080","word":"","label":"","flags":{"walkable":true}},{"gfx":"8080C0C0C0C0E0F0F8FCE6E6E0B0B0B0808183838383878F9FBFE7E7868C8C8C","word":"","label":"player-frame1","flags":[]},{"gfx":"8080808084CCFCFCFCFCFCF8F0B0B0B080808080E1E1E1F1B99F9F8F8F8C8C8C","word":"","label":"","flags":[]},{"gfx":"D5D5D5858585A5A5A5A5858585D5D5D5AAAAAAA8A8A8A9A9A9A9A8A8A8AAAAAA","word":"","label":"","flags":[]},{"gfx":"8080D4D0D0D0D4D45454D4D4D4D0808080808A8282828A8A8A0A0A8A8A828080","word":"pot","label":"","flags":[]},{"gfx":"8080808080D490948484A48494D080808080808080AA88A8A0A5A5A0A88A8080","word":"","label":"","flags":[]},{"gfx":"8080D4D0D0D0D4D45454D4D4D4D0808080808A8282828A8A8A0A0A8A8A828080","word":"","label":"","flags":[]},{"gfx":"000000A0908884827E0A0A0A0000000000000000201008040785858500000000","word":"","label":"","flags":[]},{"gfx":"000014040414500000000000A888A8800000282020280A010101010195919580","word":"","label":"","flags":[]},{"gfx":"00008C92921C60105010781C0E070300000098A4A41C030504050F1C38706000","word":"","label":"","flags":[]}] \ No newline at end of file +[{"gfx":"8080808080808080808080808080808080808080808080808080808080808080","word":"","label":"","flags":{"walkable":true}},{"gfx":"8080C0C0C0C0E0F0F8FCE6E6E0B0B0B0808183838383878F9FBFE7E7868C8C8C","word":"","label":"player-frame1","flags":[]},{"gfx":"8080808084CCFCFCFCFCFCF8F0B0B0B080808080E1E1E1F1B99F9F8F8F8C8C8C","word":"","label":"","flags":[]},{"gfx":"D5D5D5858585A5A5A5A5858585D5D5D5AAAAAAA8A8A8A9A9A9A9A8A8A8AAAAAA","word":"","label":"","flags":[]},{"gfx":"8080D4D0D0D0D4D45454D4D4D4D0808080808A8282828A8A8A0A0A8A8A828080","word":"pot","label":"","flags":[]},{"gfx":"8080808080D490948484A48494D080808080808080AA88A8A0A5A5A0A88A8080","word":"","label":"","flags":[]},{"gfx":"8080D4D0D0D0D4D45454D4D4D4D0808080808A8282828A8A8A0A0A8A8A828080","word":"","label":"","flags":[]},{"gfx":"000000A0908884827E0A0A0A0000000000000000201008040785858500000000","word":"","label":"","flags":[]},{"gfx":"000014040414500000000000A888A8800000282020280A010101010195919580","word":"","label":"","flags":[]},{"gfx":"00008C92921C60105010781C0E070300000098A4A41C030504050F1C38706000","word":"","label":"","flags":[]},{"gfx":"000000004040000000D4D4ECECECD480000000000202010101AAAAB6B6B6AA80","word":"","label":"","flags":[]},{"gfx":"0000000000004828282828482800000000000000000004050505050405000000","word":"","label":"","flags":[]}] \ No newline at end of file diff --git a/inspector/init.fnl b/inspector/init.fnl new file mode 100644 index 0000000..9d83900 --- /dev/null +++ b/inspector/init.fnl @@ -0,0 +1,68 @@ +(local util (require :lib.util)) +(local style (require :core.style)) +(local {: defmulti : defmethod} (util.require :lib.multimethod)) +(local {: textbutton} (util.require :editor.imstate)) + +(local inspector (util.hot-table ...)) + +(fn inspector.best-inspector [v] + (var best-inspector nil) + (var best-priority -1) + (each [inspector {: priority : predicate} (pairs inspector.inspectors)] + (when (and (> priority best-priority) (predicate v)) + (set best-inspector inspector) + (set best-priority priority))) + best-inspector) + +(set inspector.inspect + (defmulti (fn [state value view x y w] + (when (= state.inspector nil) + (set state.inspector (inspector.best-inspector value))) + state.inspector) :inspect ...)) + +(fn inspector.register [name priority predicate inspect-func] + (when (= inspector.inspectors nil) + (set inspector.inspectors {})) + (tset inspector.inspectors name {: predicate : priority :inspector inspect-func}) + (defmethod inspector.inspect name inspect-func)) + +(fn inspector.text-height [text ?font] + (let [font (or ?font style.code_font) + (_ newlines) (text:gsub "\n" "\n")] + (* (font:get_height) (+ newlines 1)))) + +(fn inspector.draw-text [font text x y color] + (renderer.draw_text font text x y color) + (inspector.text-height text)) + +(inspector.register :default 0 #true (fn [state value view x y w] + (inspector.draw-text style.code_font (fv value) x y style.text))) + +(inspector.register :table 10 + #(and (= (type $1) :table) (not= (next $1) nil)) + (fn [state tbl view x y w] + (local font style.code_font) + (var h 0) + ; todo: state assumes an .inspector key + ; todo: inspector swapping + ; todo: edit in place? + (fn get-kstate [tbl k state] + (when (= nil state.keys) (set state.keys {})) + (when (= nil (?. state.keys k)) + (util.nested-tset state [:keys k] {:collapsed (= (type (. tbl k)) :table) :children {}})) + (. state.keys k)) + (each [k v (pairs tbl)] + (let [kstate (get-kstate tbl k state) + kstr (fv k) + wk (font:get_width kstr) + xoffset (+ wk style.padding.x) + toggle-collapse (textbutton view kstr x (+ y h)) + hv (if kstate.collapsed + (inspector.draw-text font "..." (+ x xoffset) (+ y h) style.syntax.comment) + (inspector.inspect kstate.children v view (+ x xoffset) (+ y h) (- w xoffset)))] + (when toggle-collapse (set kstate.collapsed (not kstate.collapsed))) + (set h (+ h hv style.padding.y)))) + h)) + +inspector.hot + diff --git a/lib/fennel.lua b/lib/fennel.lua index 7384b1e..4646342 100644 --- a/lib/fennel.lua +++ b/lib/fennel.lua @@ -333,12 +333,14 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end local function table_kv_pairs(t) local assoc_3f = false + local i = 1 local kv = {} local insert = table.insert for k, v in pairs(t) do - if (type(k) ~= "number") then + if ((type(k) ~= "number") or (k ~= i)) then assoc_3f = true end + i = (i + 1) insert(kv, {k, v}) end table.sort(kv, sort_keys) @@ -378,21 +380,19 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return seen0 end - local function detect_cycle(t, seen) - local seen0 = (seen or {}) - seen0[t] = true - for k, v in pairs(t) do - if ((type(k) == "table") and (seen0[k] or detect_cycle(k, seen0))) then - return true - end - if ((type(v) == "table") and (seen0[v] or detect_cycle(v, seen0))) then - return true + local function detect_cycle(t, seen, _3fk) + if ("table" == type(t)) then + seen[t] = true + local _2_0, _3_0 = next(t, _3fk) + if ((nil ~= _2_0) and (nil ~= _3_0)) then + local k = _2_0 + local v = _3_0 + return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k)) end end - return nil 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 (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(t, indent, id) local opener_length = nil @@ -403,7 +403,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return (indent + opener_length) end - local pp = {} + local pp = nil local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix) local indent_str = ("\n" .. string.rep(" ", indent)) local open = nil @@ -422,13 +422,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) close = "}" end local oneline = (open .. table.concat(elements, " ") .. close) - local _4_ - if (table_type == "seq") then - _4_ = options["sequential-length"] - else - _4_ = options["associative-length"] - end - if (not options["one-line?"] and (multiline_3f or (#elements > _4_) or ((indent + #oneline) > options["line-length"]))) then + if (not options["one-line?"] and (multiline_3f or ((indent + #oneline) > options["line-length"]))) then return (open .. table.concat(elements, indent_str) .. close) else return oneline @@ -464,7 +458,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else prefix = "" end - local elements = nil + local items = nil do local tbl_0_ = {} for _, _6_0 in pairs(kv) do @@ -473,16 +467,16 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local v = _7_[2] local _8_ do - local k0 = pp.pp(k, options, (indent0 + 1), true) - local v0 = pp.pp(v, options, (indent0 + slength(k0) + 1)) + local k0 = pp(k, options, (indent0 + 1), true) + local v0 = pp(v, options, (indent0 + slength(k0) + 1)) multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) _8_ = (k0 .. " " .. v0) end tbl_0_[(#tbl_0_ + 1)] = _8_ end - elements = tbl_0_ + items = tbl_0_ end - return concat_table_lines(elements, options, multiline_3f, indent0, "table", prefix) + return concat_table_lines(items, options, multiline_3f, indent0, "table", prefix) end end local function pp_sequence(t, kv, options, indent) @@ -502,7 +496,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else prefix = "" end - local elements = nil + local items = nil do local tbl_0_ = {} for _, _3_0 in pairs(kv) do @@ -511,15 +505,15 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local v = _4_[2] local _5_ do - local v0 = pp.pp(v, options, indent0) + local v0 = pp(v, options, indent0) multiline_3f = (multiline_3f or v0:find("\n")) _5_ = v0 end tbl_0_[(#tbl_0_ + 1)] = _5_ end - elements = tbl_0_ + items = tbl_0_ end - return concat_table_lines(elements, options, multiline_3f, indent0, "seq", prefix) + return concat_table_lines(items, options, multiline_3f, indent0, "seq", prefix) end end local function concat_lines(lines, options, indent, force_multi_line_3f) @@ -561,7 +555,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end options["visible-cycle?"] = _2_ _ = nil - local lines, force_multi_line_3f = metamethod(t, pp.pp, options, indent) + local lines, force_multi_line_3f = metamethod(t, pp, options, indent) options["visible-cycle?"] = nil local _3_0 = type(lines) if (_3_0 == "string") then @@ -570,7 +564,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return concat_lines(lines, options, indent, force_multi_line_3f) else local _0 = _3_0 - return error("Error: __fennelview metamethod must return a table of lines") + return error("__fennelview metamethod must return a table of lines") end end end @@ -622,31 +616,28 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return x0 end local function number__3estring(n) - local _2_0, _3_0, _4_0 = math.modf(n) - if ((nil ~= _2_0) and (_3_0 == 0)) then - local int = _2_0 - return tostring(int) - else - local _5_ - do - local frac = _3_0 - _5_ = (((_2_0 == 0) and (nil ~= _3_0)) and (frac < 0)) - end - if _5_ then - local frac = _3_0 - return ("-0." .. tostring(frac):gsub("^-?0.", "")) - elseif ((nil ~= _2_0) and (nil ~= _3_0)) then - local int = _2_0 - local frac = _3_0 - return (int .. "." .. tostring(frac):gsub("^-?0.", "")) - end - end + local _2_0 = string.gsub(tostring(n), ",", ".") + return _2_0 end local function colon_string_3f(s) - return s:find("^[-%w?\\^_!$%&*+./@:|<=>]+$") + return s:find("^[-%w?^_!$%&*+./@|<=>]+$") + end + local function pp_string(str, options, indent) + local escs = nil + local _2_ + if (options["escape-newlines?"] and (#str < (options["line-length"] - indent))) then + _2_ = "\\n" + else + _2_ = "\n" + end + local function _4_(_241, _242) + return ("\\%03d"):format(_242:byte()) + end + escs = setmetatable({["\""] = "\\\"", ["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\\"] = "\\\\", ["\n"] = _2_}, {__index = _4_}) + return ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"") end local function make_options(t, options) - local defaults = {["associative-length"] = 4, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["line-length"] = 80, ["metamethod?"] = true, ["one-line?"] = false, ["sequential-length"] = 10, ["utf8?"] = true, depth = 128} + local defaults = {["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["escape-newlines?"] = false, ["line-length"] = 80, ["metamethod?"] = true, ["one-line?"] = false, ["prefer-colon?"] = false, ["utf8?"] = true, depth = 128} local overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}} for k, v in pairs((options or {})) do defaults[k] = v @@ -656,34 +647,46 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return defaults end - pp.pp = function(x, options, indent, key_3f) + local function _2_(x, options, indent, colon_3f) local indent0 = (indent or 0) local options0 = (options or make_options(x)) local tv = type(x) - local function _3_() - local _2_0 = getmetatable(x) - if _2_0 then - return _2_0.__fennelview + local function _4_() + local _3_0 = getmetatable(x) + if _3_0 then + return _3_0.__fennelview else - return _2_0 + return _3_0 end end - if ((tv == "table") or ((tv == "userdata") and _3_())) then + if ((tv == "table") or ((tv == "userdata") and _4_())) then return pp_table(x, options0, indent0) elseif (tv == "number") then return number__3estring(x) - elseif ((tv == "string") and key_3f and colon_string_3f(x)) then - return (":" .. x) - elseif (tv == "string") then - return string.format("%q", x) - elseif ((tv == "boolean") or (tv == "nil")) then - return tostring(x) else - return ("#<" .. tostring(x) .. ">") + local function _5_() + if (colon_3f ~= nil) then + return colon_3f + elseif ("function" == type(options0["prefer-colon?"])) then + return options0["prefer-colon?"](x) + else + return options0["prefer-colon?"] + end + end + if ((tv == "string") and colon_string_3f(x) and _5_()) then + return (":" .. x) + elseif (tv == "string") then + return pp_string(x, options0, indent0) + elseif ((tv == "boolean") or (tv == "nil")) then + return tostring(x) + else + return ("#<" .. tostring(x) .. ">") + end end end + pp = _2_ local function view(x, options) - return pp.pp(x, make_options(x, options), 0) + return pp(x, make_options(x, options), 0) end return view end @@ -870,8 +873,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function set_fn_metadata(arg_list, docstring, parent, fn_name) if utils.root.options.useMetadata then local args = nil - local function _0_(v) - return ("\"%s\""):format(deep_tostring(v)) + local function _0_(_241) + return ("\"%s\""):format(deep_tostring(_241)) end args = utils.map(arg_list, _0_) local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")} @@ -893,9 +896,30 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end return _0_, not multi, 3 else - return compiler.gensym(scope), true, 2 + return nil, true, 2 end end + local function compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, local_3f, arg_name_list, arg_list, docstring) + 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 _0_ + if local_3f then + _0_ = "local function %s(%s)" + else + _0_ = "%s = function(%s)" + end + compiler.emit(parent, string.format(_0_, fn_name, table.concat(arg_name_list, ", ")), ast) + compiler.emit(parent, f_chunk, ast) + compiler.emit(parent, "end", ast) + set_fn_metadata(arg_list, docstring, parent, fn_name) + utils.hook("fn", ast, f_scope) + return utils.expr(fn_name, "sym") + end + local function compile_anonymous_fn(ast, f_scope, f_chunk, parent, index, arg_name_list, arg_list, docstring, scope) + local fn_name = compiler.gensym(scope) + return compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, true, arg_name_list, arg_list, docstring) + end SPECIALS.fn = function(ast, scope, parent) local f_scope = nil do @@ -906,7 +930,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local f_chunk = {} local fn_sym = utils["sym?"](ast[2]) local multi = (fn_sym and utils["multi-sym?"](fn_sym[1])) - local fn_name, local_fn_3f, index = get_fn_name(ast, scope, fn_sym, multi) + 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) @@ -925,30 +949,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[2]) end end - do - local arg_name_list = utils.map(arg_list, get_arg_name) - local index0, docstring = nil, nil - if ((type(ast[(index + 1)]) == "string") and ((index + 1) < #ast)) then - index0, docstring = (index + 1), ast[(index + 1)] - else - index0, docstring = index, nil - end - for i = (index0 + 1), #ast do - compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)}) - end - local _2_ - if local_fn_3f then - _2_ = "local function %s(%s)" - else - _2_ = "%s = function(%s)" - end - compiler.emit(parent, string.format(_2_, fn_name, table.concat(arg_name_list, ", ")), ast) - compiler.emit(parent, f_chunk, ast) - compiler.emit(parent, "end", ast) - set_fn_metadata(arg_list, docstring, parent, fn_name) + local arg_name_list = utils.map(arg_list, get_arg_name) + local index0, docstring = nil, nil + if ((type(ast[(index + 1)]) == "string") and ((index + 1) < #ast)) then + index0, docstring = (index + 1), ast[(index + 1)] + else + index0, docstring = index, nil + end + if fn_name then + return compile_named_fn(ast, f_scope, f_chunk, parent, index0, fn_name, local_3f, arg_name_list, arg_list, docstring) + else + return compile_anonymous_fn(ast, f_scope, f_chunk, parent, index0, arg_name_list, arg_list, docstring, scope) end - utils.hook("fn", ast, f_scope) - return utils.expr(fn_name, "sym") end doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring.\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.") SPECIALS.lua = function(ast, _, parent) @@ -968,8 +980,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if special_or_macro then return ("print(%q)"):format(doc_2a(special_or_macro, target)) else - local value = tostring(compiler.compile1(ast[2], scope, parent, {nval = 1})[1]) - return ("print(require('%s').doc(%s, '%s'))"):format((utils.root.options.moduleName or "fennel"), value, tostring(ast[2])) + local _0_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local value = _0_[1] + return ("print(require('%s').doc(%s, '%s'))"):format((utils.root.options.moduleName or "fennel"), tostring(value), tostring(ast[2])) end end doc_special("doc", {"x"}, "Print the docstring and arglist for a function, macro, or special form.") @@ -1121,7 +1134,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local cond = tostring(branch.cond) local cond_line = nil - if ((cond == "true") and branch.nested and (i == #branches)) then + if ((cond == "true") and branch.nested and (i == #branches) and not has_else_3f) then cond_line = "else" else cond_line = fstr:format(cond) @@ -1173,9 +1186,23 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end SPECIALS["if"] = if_2a doc_special("if", {"cond1", "body1", "...", "condN", "bodyN"}, "Conditional form.\nTakes any number of condition/body pairs and evaluates the first body where\nthe condition evaluates to truthy. Similar to cond in other lisps.") + local function remove_until_condition(bindings) + if ("until" == bindings[(#bindings - 1)]) then + table.remove(bindings, (#bindings - 1)) + return table.remove(bindings) + end + end + local function compile_until(condition, scope, chunk) + if condition then + local _0_ = compiler.compile1(condition, scope, chunk, {nval = 1}) + local condition_lua = _0_[1] + return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), condition) + end + end SPECIALS.each = function(ast, scope, parent) compiler.assert((#ast >= 3), "expected body expression", ast[1]) local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) + local until_condition = remove_until_condition(binding) local iter = table.remove(binding, #binding) local destructures = {} local new_manglings = {} @@ -1198,6 +1225,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"}) end compiler["apply-manglings"](sub_scope, new_manglings, ast) + compile_until(until_condition, sub_scope, chunk) compile_do(ast, sub_scope, chunk, 3) compiler.emit(parent, chunk, ast) return compiler.emit(parent, "end", ast) @@ -1226,6 +1254,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.") local function for_2a(ast, scope, parent) local ranges = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) + local until_condition = remove_until_condition(ast[2]) local binding_sym = table.remove(ast[2], 1) local sub_scope = compiler["make-scope"](scope) local range_args = {} @@ -1236,6 +1265,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct range_args[i] = tostring(compiler.compile1(ranges[i], sub_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) compile_do(ast, sub_scope, chunk, 3) compiler.emit(parent, chunk, ast) return compiler.emit(parent, "end", ast) @@ -1361,40 +1391,41 @@ 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 define_arithmetic_special(name, zero_arity, unary_prefix, lua_name) - do - local padded_op = (" " .. (lua_name or name) .. " ") - local function _0_(ast, scope, parent) - local len = #ast - if (len == 1) then - compiler.assert((zero_arity ~= nil), "Expected more than 0 arguments", ast) - return utils.expr(zero_arity, "literal") + local function arithmetic_special(name, zero_arity, unary_prefix, ast, scope, parent) + local len = #ast + if (len == 1) then + compiler.assert(zero_arity, "Expected more than 0 arguments", ast) + return utils.expr(zero_arity, "literal") + else + local operands = {} + local padded_op = (" " .. name .. " ") + for i = 2, len do + local subexprs = nil + local _0_ + if (i ~= len) then + _0_ = 1 else - local operands = {} - for i = 2, len do - local subexprs = nil - local _1_ - if (i ~= len) then - _1_ = 1 - else - _1_ = nil - end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _1_}) - utils.map(subexprs, tostring, operands) - end - if (#operands == 1) then - if unary_prefix then - return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")") - else - return operands[1] - end - else - return ("(" .. table.concat(operands, padded_op) .. ")") - end + _0_ = nil end + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _0_}) + utils.map(subexprs, tostring, operands) + end + if (#operands == 1) then + if unary_prefix then + return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")") + else + return operands[1] + end + else + return ("(" .. table.concat(operands, padded_op) .. ")") end - SPECIALS[name] = _0_ end + end + local function define_arithmetic_special(name, zero_arity, unary_prefix, lua_name) + local function _0_(...) + return arithmetic_special((lua_name or name), zero_arity, unary_prefix, ...) + end + SPECIALS[name] = _0_ return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.") end define_arithmetic_special("+", "0") @@ -1405,16 +1436,57 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct define_arithmetic_special("%") define_arithmetic_special("/", nil, "1") define_arithmetic_special("//", nil, "1") - define_arithmetic_special("lshift", nil, "1", "<<") - define_arithmetic_special("rshift", nil, "1", ">>") - define_arithmetic_special("band", "0", "0", "&") - define_arithmetic_special("bor", "0", "0", "|") - define_arithmetic_special("bxor", "0", "0", "~") - doc_special("lshift", {"x", "n"}, "Bitwise logical left shift of x by n bits; only works in Lua 5.3+.") - doc_special("rshift", {"x", "n"}, "Bitwise logical right shift of x by n bits; only works in Lua 5.3+.") - doc_special("band", {"x1", "x2"}, "Bitwise AND of arguments; only works in Lua 5.3+.") - doc_special("bor", {"x1", "x2"}, "Bitwise OR of arguments; only works in Lua 5.3+.") - doc_special("bxor", {"x1", "x2"}, "Bitwise XOR of arguments; only works in Lua 5.3+.") + local function bitop_special(native_name, lib_name, zero_arity, unary_prefix, ast, scope, parent) + if (#ast == 1) then + return compiler.assert(zero_arity, "Expected more than 0 arguments.", ast) + else + local len = #ast + local operands = {} + local padded_native_name = (" " .. native_name .. " ") + local prefixed_lib_name = ("bit." .. lib_name) + for i = 2, len do + local subexprs = nil + local _0_ + if (i ~= len) then + _0_ = 1 + else + _0_ = nil + end + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _0_}) + utils.map(subexprs, tostring, operands) + end + if (#operands == 1) then + if utils.root.options.useBitLib then + return (prefixed_lib_name .. "(" .. unary_prefix .. ", " .. operands[1] .. ")") + else + return ("(" .. unary_prefix .. padded_native_name .. operands[1] .. ")") + end + else + if utils.root.options.useBitLib then + return (prefixed_lib_name .. "(" .. table.concat(operands, ", ") .. ")") + else + return ("(" .. table.concat(operands, padded_native_name) .. ")") + end + end + end + end + local function define_bitop_special(name, zero_arity, unary_prefix, native) + local function _0_(...) + return bitop_special(native, name, zero_arity, unary_prefix, ...) + end + SPECIALS[name] = _0_ + return nil + end + define_bitop_special("lshift", nil, "1", "<<") + define_bitop_special("rshift", nil, "1", ">>") + define_bitop_special("band", "0", "0", "&") + define_bitop_special("bor", "0", "0", "|") + define_bitop_special("bxor", "0", "0", "~") + doc_special("lshift", {"x", "n"}, "Bitwise logical left shift of x by n bits.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") + doc_special("rshift", {"x", "n"}, "Bitwise logical right shift of x by n bits.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") + doc_special("band", {"x1", "x2", "..."}, "Bitwise AND of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") + 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.") define_arithmetic_special("or", "false") define_arithmetic_special("and", "true") doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") @@ -1466,7 +1538,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct define_comparator_special("<=") define_comparator_special("=", "==") define_comparator_special("not=", "~=", "or") - SPECIALS["~="] = SPECIALS["not="] local function define_unary_special(op, realop) local function opfn(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) @@ -1479,9 +1550,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct define_unary_special("not", "not ") doc_special("not", {"x"}, "Logical operator; works the same as Lua.") define_unary_special("bnot", "~") - doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+.") + 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.") + SPECIALS["~="] = SPECIALS["not="] SPECIALS["#"] = SPECIALS.length SPECIALS.quote = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument") @@ -1496,7 +1568,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end doc_special("quote", {"x"}, "Quasiquote the following form. Only works in macro/compiler scope.") local already_warned_3f = {} - local compile_env_warning = ("WARNING: Attempting to %s %s in compile" .. " scope.\nIn future versions of Fennel this will not" .. " be allowed without the\n--no-compiler-sandbox flag" .. " or passing a :compilerEnv globals table in options.\n") + local compile_env_warning = table.concat({"WARNING: Attempting to %s %s in compile scope.", "In future versions of Fennel this will not be allowed without the", "--no-compiler-sandbox flag or passing a :compilerEnv globals table", "in the options.\n"}, "\n") local function compiler_env_warn(_, key) local v = _G[key] if (v and io and io.stderr and not already_warned_3f[key]) then @@ -1505,8 +1577,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end return v end - local safe_compiler_env = setmetatable({assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = getmetatable, ipairs = ipairs, math = math, next = next, pairs = pairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, select = select, setmetatable = setmetatable, string = string, table = table, tonumber = tonumber, tostring = tostring, type = type, xpcall = xpcall}, {__index = compiler_env_warn}) - local function make_compiler_env(ast, scope, parent) + local function safe_getmetatable(tbl) + local mt = getmetatable(tbl) + assert((mt ~= getmetatable("")), "Illegal metatable access!") + return mt + end + local safe_require = nil + local function safe_compiler_env(strict_3f) + local _1_ + if strict_3f then + _1_ = nil + else + _1_ = compiler_env_warn + end + return setmetatable({assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = pairs, 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, xpcall = xpcall}, {__index = _1_}) + end + local function make_compiler_env(ast, scope, parent, strict_3f) local function _1_() return compiler.scopes.macro end @@ -1524,7 +1610,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local _6_ do local _5_0 = utils.root.options - if ((type(_5_0) == "table") and (nil ~= _5_0.compilerEnv)) then + if ((type(_5_0) == "table") and (_5_0["compiler-env"] == "strict")) then + _6_ = safe_compiler_env(true) + elseif ((type(_5_0) == "table") and (nil ~= _5_0.compilerEnv)) then local compilerEnv = _5_0.compilerEnv _6_ = compilerEnv elseif ((type(_5_0) == "table") and (nil ~= _5_0["compiler-env"])) then @@ -1532,7 +1620,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct _6_ = compiler_env else local _ = _5_0 - _6_ = safe_compiler_env + _6_ = safe_compiler_env(false) end end return setmetatable({["assert-compile"] = compiler.assert, ["get-scope"] = _1_, ["in-scope?"] = _2_, ["list?"] = utils["list?"], ["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(), gensym = _3_, list = utils.list, macroexpand = _4_, sequence = utils.sequence, sym = utils.sym, unpack = unpack, view = view}, {__index = _6_}) @@ -1592,10 +1680,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end return allowed end - local function compiler_env_domodule(modname, env, _3fast) - local filename = compiler.assert(search_module(modname), (modname .. " module not found."), _3fast) - local globals = macro_globals(env, current_global_names()) - return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata}, modname, filename) + local function default_macro_searcher(module_name) + local _1_0 = search_module(module_name) + if (nil ~= _1_0) then + local filename = _1_0 + local function _2_(...) + return utils["fennel-module"].dofile(filename, {env = "_COMPILER"}, ...) + end + return _2_, filename + end + end + local macro_searchers = {default_macro_searcher} + local function search_macro_module(modname, n) + local _1_0 = macro_searchers[n] + if (nil ~= _1_0) then + local f = _1_0 + local _2_0, _3_0 = f(modname) + if ((nil ~= _2_0) and true) then + local loader = _2_0 + local _3ffilename = _3_0 + return loader, _3ffilename + else + local _ = _2_0 + return search_macro_module(modname, (n + 1)) + end + end end local macro_loaded = {} local function metadata_only_fennel(modname) @@ -1603,14 +1712,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return {metadata = compiler.metadata} end end - safe_compiler_env.require = function(modname) - local function _1_() - local mod = compiler_env_domodule(modname, safe_compiler_env) - macro_loaded[modname] = mod - return mod + local function _1_(modname) + local function _2_() + local loader, filename = search_macro_module(modname, 1) + compiler.assert(loader, (modname .. " module not found.")) + macro_loaded[modname] = loader(modname, filename) + return macro_loaded[modname] end - return (macro_loaded[modname] or metadata_only_fennel(modname) or _1_()) + return (macro_loaded[modname] or metadata_only_fennel(modname) or _2_()) end + safe_require = _1_ 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 @@ -1622,12 +1733,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct SPECIALS["require-macros"] = function(ast, scope, parent, real_ast) compiler.assert((#ast == 2), "Expected one module name argument", (real_ast or ast)) local filename = (ast[2].filename or ast.filename) - local modname_code = compiler.compile(ast[2]) - local modname = load_code(modname_code, nil, filename)(utils.root.options["module-name"], filename) + local modname_chunk = load_code(compiler.compile(ast[2]), nil, filename) + local modname = modname_chunk(utils.root.options["module-name"], filename) compiler.assert((type(modname) == "string"), "module name must compile to string", (real_ast or ast)) if not macro_loaded[modname] then local env = make_compiler_env(ast, scope, parent) - macro_loaded[modname] = compiler_env_domodule(modname, env, ast) + local loader, filename0 = search_macro_module(modname, 1) + compiler.assert(loader, (modname .. " module not found."), ast) + macro_loaded[modname] = loader(modname, filename0) end return add_macros(macro_loaded[modname], ast, scope, parent) end @@ -1666,10 +1779,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return error(..., 0) end end - local function _1_() + local function _2_() return f:read("*all"):gsub("[\13\n]*$", "") end - src = close_handlers_0_(xpcall(_1_, (package.loaded.fennel or debug).traceback)) + src = close_handlers_0_(xpcall(_2_, (package.loaded.fennel or debug).traceback)) end local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") local target = ("package.preload[%q]"):format(mod) @@ -1706,13 +1819,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end else local mod = load_code(("return " .. modexpr[1]))() - local function _2_() - local _1_0 = search_module(mod) - if (nil ~= _1_0) then - local fennel_path = _1_0 + local function _3_() + local _2_0 = search_module(mod) + if (nil ~= _2_0) then + local fennel_path = _2_0 return include_path(ast, opts, fennel_path, mod, true) else - local _ = _1_0 + local _ = _2_0 local lua_path = search_module(mod, package.path) if lua_path then return include_path(ast, opts, lua_path, mod, false) @@ -1723,7 +1836,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end end - return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _2_()) + return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _3_()) end end doc_special("include", {"module-name-literal"}, "Like require but load the target module during compilation and embed it in the\nLua output. The module must be a string literal and resolvable at compile time.") @@ -1747,7 +1860,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return val end doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.") - return {["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["make-compiler-env"] = make_compiler_env, ["make-searcher"] = make_searcher, ["search-module"] = search_module, ["wrap-env"] = wrap_env, doc = doc_2a} + 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") @@ -1920,7 +2033,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local name = utils.deref(symbol) if (io and io.stderr and name:find("&") and not already_warned[symbol]) then already_warned[symbol] = true - do end (io.stderr):write(("-- Warning: & will not be allowed in identifier names in " .. "future versions: " .. symbol.filename .. ":" .. symbol.line .. "\n")) + do end (io.stderr):write(("-- Warning: & will not be allowed in identifier names in " .. "future versions: " .. (symbol.filename or "unknown") .. ":" .. (symbol.line or "?") .. "\n")) end assert_compile(not (scope.specials[name] or 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) @@ -1955,7 +2068,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if (local_3f and scope.symmeta[parts[1]]) then scope.symmeta[parts[1]]["used"] = true end - assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. parts[1]), symbol) + assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol) if (allowed_globals and not local_3f) then utils.root.scope.refedglobals[parts[1]] = true end @@ -1985,6 +2098,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return utils.map(chunk, peephole) end end + local function ast_source(ast) + local m = getmetatable(ast) + return ((m and m.line and m) or (("table" == type(ast)) and ast) or {}) + end local function flatten_chunk_correlated(main_chunk) local function flatten(chunk, out, last_line, file) local last_line0 = last_line @@ -1993,8 +2110,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else for _, subchunk in ipairs(chunk) do if (subchunk.leaf or (#subchunk > 0)) then - if (subchunk.ast and (file == subchunk.ast.file)) then - last_line0 = math.max(last_line0, (subchunk.ast.line or 0)) + local source = ast_source(subchunk.ast) + if (file == source.file) then + last_line0 = math.max(last_line0, (source.line or 0)) end last_line0 = flatten(subchunk, out, last_line0, file) end @@ -2016,7 +2134,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local code = chunk.leaf local info = chunk.ast if sm then - table.insert(sm, ((info and info.line) or ( - 1))) + table.insert(sm, {(info and info.filename), (info and info.line)}) end return code else @@ -2065,7 +2183,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local sm = {} local ret = flatten_chunk(sm, chunk0, options.indent, 0) if sm then - sm.short_src = make_short_src((options.filename or options.source or ret)) + sm.short_src = (options.filename or make_short_src((options.source or ret))) if options.filename then sm.key = ("@" .. options.filename) else @@ -2104,15 +2222,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local function exprs1(exprs) return table.concat(utils.map(exprs, 1), ", ") end + local function disambiguate_parens(code, chunk) + if ((code:byte() == 40) and (1 < #chunk)) then + return ("; " .. code) + else + return code + end + end local function keep_side_effects(exprs, chunk, start, ast) - local start0 = (start or 1) - for j = start0, #exprs do + for j = (start or 1), #exprs do local se = exprs[j] if ((se.type == "expression") and (se[1] ~= "nil")) then emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) elseif (se.type == "statement") then - local code = tostring(se) - emit(chunk, (((code:byte() == 40) and ("do end " .. code)) or code), ast) + emit(chunk, disambiguate_parens(tostring(se), chunk), ast) end end return nil @@ -2174,26 +2297,35 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function macroexpand_2a(ast, scope, once) - if not utils["list?"](ast) then - return ast + local _0_0 = nil + if utils["list?"](ast) then + _0_0 = find_macro(ast, scope, utils["multi-sym?"](ast[1])) else - local macro_2a = find_macro(ast, scope, utils["multi-sym?"](ast[1])) - if not macro_2a then - return ast - else - local old_scope = scopes.macro - local _ = nil - scopes.macro = scope - _ = nil - local ok, transformed = pcall(macro_2a, unpack(ast, 2)) - scopes.macro = old_scope - assert_compile(ok, transformed, ast) - if (once or not transformed) then - return transformed - else - return macroexpand_2a(transformed, scope) - end + _0_0 = nil + end + if (_0_0 == false) then + return ast + elseif (nil ~= _0_0) then + local macro_2a = _0_0 + local old_scope = scopes.macro + local _ = nil + scopes.macro = scope + _ = nil + local ok, transformed = nil, nil + local function _2_() + return macro_2a(unpack(ast, 2)) end + ok, transformed = xpcall(_2_, debug.traceback) + scopes.macro = old_scope + assert_compile(ok, transformed, ast) + if (once or not transformed) then + return transformed + else + return macroexpand_2a(transformed, scope) + end + else + local _ = _0_0 + return ast end end local function compile_special(ast, scope, parent, opts, special) @@ -2255,7 +2387,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".") local method_to_call = multi_sym_parts[#multi_sym_parts] - local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call, select(2, unpack(ast))) + local new_ast = utils.list(utils.sym(":", nil, scope), utils.sym(table_with_method, nil, scope), method_to_call, select(2, unpack(ast))) return compile1(new_ast, scope, parent, opts) else return compile_function_call(ast, scope, parent, opts, compile1, len) @@ -2277,25 +2409,8 @@ 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 _0_0, _1_0, _2_0 = math.modf(n) - if ((nil ~= _0_0) and (_1_0 == 0)) then - local int = _0_0 - return tostring(int) - else - local _3_ - do - local frac = _1_0 - _3_ = (((_0_0 == 0) and (nil ~= _1_0)) and (frac < 0)) - end - if _3_ then - local frac = _1_0 - return ("-0." .. tostring(frac):gsub("^-?0.", "")) - elseif ((nil ~= _0_0) and (nil ~= _1_0)) then - local int = _0_0 - local frac = _1_0 - return (int .. "." .. tostring(frac):gsub("^-?0.", "")) - end - end + local _0_0 = string.gsub(tostring(n), ",", ".") + return _0_0 end local function compile_scalar(ast, _scope, parent, opts) local serialize = nil @@ -2343,9 +2458,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct table.sort(_0_0, _1_) keys = _0_0 end - local function _1_(k) - local v = tostring(compile1(ast[k[2]], scope, parent, {nval = 1})[1]) - return string.format("%s = %s", k[1], v) + local function _1_(_2_0) + local _3_ = _2_0 + local k1 = _3_[1] + local k2 = _3_[2] + local _4_ = compile1(ast[k2], scope, parent, {nval = 1}) + local v = _4_[1] + return string.format("%s = %s", k1, tostring(v)) end utils.map(keys, _1_, buffer) end @@ -2375,8 +2494,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local forceglobal = _0_["forceglobal"] local forceset = _0_["forceset"] local isvar = _0_["isvar"] - local nomulti = _0_["nomulti"] - local noundef = _0_["noundef"] local symtype = _0_["symtype"] local symtype0 = ("_" .. (symtype or "dst")) local setter = nil @@ -2388,7 +2505,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local new_manglings = {} local function getname(symbol, up1) local raw = symbol[1] - assert_compile(not (nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1) + assert_compile(not (opts0.nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1) if declaration then return declare_local(symbol, nil, scope, symbol, new_manglings) else @@ -2397,7 +2514,7 @@ 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 noundef), ("expected local " .. parts[1]), symbol) + assert_compile((meta or not opts0.noundef), ("expected local " .. parts[1]), symbol) end if forceglobal then assert_compile(not scope.symmeta[scope.unmanglings[raw]], ("global " .. raw .. " conflicts with local"), symbol) @@ -2432,6 +2549,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end if ((#parent == (plen + 1)) and parent[#parent].leaf) then parent[#parent]["leaf"] = ("local " .. parent[#parent].leaf) + elseif (init == "nil") then + table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue)}) else table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue .. " = " .. init)}) end @@ -2606,8 +2725,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else local remap = fennel_sourcemap[info.source] if (remap and remap[info.currentline]) then - info["short-src"] = remap["short-src"] - info.currentline = remap[info.currentline] + if remap[info.currentline][1] then + info.short_src = fennel_sourcemap[("@" .. remap[info.currentline][1])].short_src + else + info.short_src = remap.short_src + end + info.currentline = (remap[info.currentline][2] or -1) end if (info.what == "Lua") then local function _1_() @@ -2618,7 +2741,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _1_()) - elseif (info["short-src"] == "(tail call)") then + elseif (info.short_src == "(tail call)") then return " (tail call)" else return string.format(" %s:%d: in main chunk", info.short_src, info.currentline) @@ -2664,9 +2787,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return _0_ end - local function no() - return nil - end local function mixed_concat(t, joiner) local seen = {} local ret, s = "", "" @@ -2700,16 +2820,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local symstr = utils.deref(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("sym('%s', nil, {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil")) + return string.format("sym('%s', {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil")) else - return string.format("sym('%s', nil, {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil")) + return string.format("sym('%s', {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil")) end elseif (utils["list?"](form) and utils["sym?"](form[1]) and (utils.deref(form[1]) == "unquote")) then local payload = form[2] local res = unpack(compile1(payload, scope, parent)) return res[1] elseif utils["list?"](form) then - local mapped = utils.kvmap(form, entry_transform(no, q)) + local mapped = nil + local function _0_() + return nil + end + mapped = utils.kvmap(form, entry_transform(_0_, q)) local filename = nil if form.filename then filename = string.format("%q", form.filename) @@ -2718,6 +2842,22 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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(list()))"), filename, (form.line or "nil"), (form.bytestart or "nil"), mixed_concat(mapped, ", ")) + elseif utils["sequence?"](form) then + local mapped = utils.kvmap(form, entry_transform(q, q)) + local source = getmetatable(form) + local filename = nil + if source.filename then + filename = string.format("%q", source.filename) + else + filename = "nil" + end + local _1_ + if source then + _1_ = source.line + else + _1_ = "nil" + end + return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _1_, "(getmetatable(sequence()))['sequence']") elseif (type(form) == "table") then local mapped = utils.kvmap(form, entry_transform(q, q)) local source = getmetatable(form) @@ -2748,7 +2888,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( local m = getmetatable(ast) return ((m and m.line and m) or (("table" == type(ast)) and ast) or {}) end - 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"}, ["could not compile value of type "] = {"debugging the macro you're calling not to return a coroutine or userdata"}, ["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 binding table"] = {"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 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"}, ["illegal 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"}, ["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"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["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 global 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"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} + 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"}, ["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 binding table"] = {"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 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"}, ["illegal 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"}, ["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"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["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 global 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"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["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 @@ -2780,21 +2920,19 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( f:close() return codeline, bytes end - local function read_line_from_source(source, line) - local lines, bytes, codeline = 0, 0 - for this_line, newline in string.gmatch((source .. "\n"), "(.-)(\13?\n)") do - lines = (lines + 1) - if (lines == line) then - codeline = this_line - break - end - bytes = (bytes + #newline + #this_line) + local function read_line_from_string(matcher, target_line, _3fcurrent_line, _3fbytes) + local this_line, newline = matcher() + local current_line = (_3fcurrent_line or 1) + local bytes = ((_3fbytes or 0) + #this_line + #newline) + if (target_line == current_line) then + return this_line, bytes + elseif this_line then + return read_line_from_string(matcher, target_line, (current_line + 1), bytes) end - return codeline, bytes end local function read_line(filename, line, source) if source then - return read_line_from_source(source, line) + return read_line_from_string(string.gmatch((source .. "\n"), "(.-)(\13?\n)"), line) else return read_line_from_file(filename, line) end @@ -2927,6 +3065,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return r end + assert(((nil == filename) or ("string" == type(filename))), "expected filename as second argument to parser") local function parse_error(msg, byteindex_override) local _0_ = (options or utils.root.options or {}) local source = _0_["source"] @@ -2947,8 +3086,17 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return nil elseif ((type(_0_0) == "table") and (nil ~= _0_0.prefix)) then local prefix = _0_0.prefix - table.remove(stack) - return dispatch(utils.list(utils.sym(prefix), v)) + local source = nil + do + local _1_0 = table.remove(stack) + _1_0["byteend"] = byteindex + source = _1_0 + end + local list = utils.list(utils.sym(prefix, source), v) + for k, v0 in pairs(source) do + list[k] = v0 + end + return dispatch(list) elseif (nil ~= _0_0) then local top = _0_0 whitespace_since_dispatch = false @@ -2984,7 +3132,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return parse_comment(getb(), _1_()) elseif (options and options.comments) then - return dispatch(utils.comment(table.concat(contents))) + return dispatch(utils.comment(table.concat(contents), {filename = filename, line = (line - 1)})) else return b end @@ -3005,7 +3153,49 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return dispatch(val) end + local function add_comment_at(comments, index, node) + local _0_0 = comments[index] + if (nil ~= _0_0) then + local existing = _0_0 + return table.insert(existing, node) + else + local _ = _0_0 + comments[index] = {node} + return nil + end + end + local function next_noncomment(tbl, i) + if utils["comment?"](tbl[i]) then + return next_noncomment(tbl, (i + 1)) + else + return tbl[i] + end + end + local function extract_comments(tbl) + local comments = {keys = {}, last = {}, values = {}} + while utils["comment?"](tbl[#tbl]) do + table.insert(comments.last, 1, table.remove(tbl)) + end + local last_key_3f = false + for i, node in ipairs(tbl) do + if not utils["comment?"](node) then + last_key_3f = not last_key_3f + elseif last_key_3f then + add_comment_at(comments.values, next_noncomment(tbl, i), node) + else + add_comment_at(comments.keys, next_noncomment(tbl, i), node) + end + end + for i = #tbl, 1, -1 do + if utils["comment?"](tbl[i]) then + table.remove(tbl, i) + end + end + return comments + end local function close_curly_table(tbl) + local comments = extract_comments(tbl) + local keys = {} local val = {} if ((#tbl % 2) ~= 0) then byteindex = (byteindex - 1) @@ -3017,7 +3207,10 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( tbl[i] = tostring(tbl[(i + 1)]) end val[tbl[i]] = tbl[(i + 1)] + table.insert(keys, tbl[i]) end + tbl.comments = comments + tbl.keys = keys return dispatch(val) end local function close_table(b) @@ -3025,7 +3218,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if (top == nil) then parse_error(("unexpected closing delimiter " .. string.char(b))) end - if (top.closer ~= b) then + if (top.closer and (top.closer ~= b)) then parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) end top.byteend = byteindex @@ -3073,9 +3266,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return dispatch(load_fn()) end local function parse_prefix(b) - table.insert(stack, {prefix = prefixes[b]}) + table.insert(stack, {bytestart = byteindex, filename = filename, line = line, prefix = prefixes[b]}) local nextb = getb() - if whitespace_3f(nextb) then + if (whitespace_3f(nextb) or (true == delims[nextb])) then if (b ~= 35) then parse_error("invalid whitespace after quoting prefix") end @@ -3116,11 +3309,13 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if (rawstr:match("^~") and (rawstr ~= "~=")) then return parse_error("illegal character: ~") elseif rawstr:match("%.[0-9]") then - return parse_error(("can't start multisym segment " .. "with a digit: " .. rawstr), (((byteindex - #rawstr) + rawstr:find("%.[0-9]")) + 1)) + return parse_error(("can't start multisym segment with a digit: " .. rawstr), (((byteindex - #rawstr) + rawstr:find("%.[0-9]")) + 1)) elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then return parse_error(("malformed multisym: " .. rawstr), ((byteindex - #rawstr) + 1 + rawstr:find("[%.:][%.:]"))) elseif rawstr:match(":.+[%.:]") then - return parse_error(("method must be last component " .. "of multisym: " .. rawstr), ((byteindex - #rawstr) + rawstr:find(":.+[%.:]"))) + return parse_error(("method must be last component of multisym: " .. rawstr), ((byteindex - #rawstr) + rawstr:find(":.+[%.:]"))) + else + return rawstr end end local function parse_sym(b) @@ -3134,12 +3329,8 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return dispatch(utils.varg()) elseif rawstr:match("^:.+$") then return dispatch(rawstr:sub(2)) - elseif parse_number(rawstr) then - return nil - elseif check_malformed_sym(rawstr) then - return nil - else - return dispatch(utils.sym(rawstr, nil, {byteend = byteindex, bytestart = bytestart, filename = filename, line = line})) + elseif not parse_number(rawstr) then + return dispatch(utils.sym(check_malformed_sym(rawstr), {byteend = byteindex, bytestart = bytestart, filename = filename, line = line})) end end local function parse_loop(b) @@ -3185,19 +3376,27 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. for k in pairs(t) do table.insert(keys, k) end - local function _0_(a, b) - return (tostring(a) < tostring(b)) + local function _0_(_241, _242) + return (tostring(_241) < tostring(_242)) end table.sort(keys, _0_) for i, k in ipairs(keys) do succ[k] = keys[(i + 1)] end local function stablenext(tbl, idx) + local key = nil if (idx == nil) then - return keys[1], tbl[keys[1]] + key = keys[1] else - return succ[idx], succ[idx] and tbl[succ[idx]] + key = succ[idx] end + local value = nil + if (key == nil) then + value = nil + else + value = tbl[key] + end + return key, value end return stablenext, t, nil end @@ -3207,9 +3406,8 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. if (type(f) == "function") then f0 = f else - local s = f - local function _0_(x) - return x[s] + local function _0_(_241) + return _241[f] end f0 = _0_ end @@ -3228,9 +3426,8 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. if (type(f) == "function") then f0 = f else - local s = f - local function _0_(x) - return x[s] + local function _0_(_241) + return _241[f] end f0 = _0_ end @@ -3302,10 +3499,19 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. end return ("(" .. table.concat(map(safe, (tostring2 or tostring)), " ", 1, max) .. ")") end - local symbol_mt = {"SYMBOL", __fennelview = deref, __tostring = deref} + local function comment_view(c) + return c, true + end + local function sym_3d(a, b) + return ((deref(a) == deref(b)) and (getmetatable(a) == getmetatable(b))) + end + local function sym_3c(a, b) + return (a[1] < tostring(b)) + end + local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref} local expr_mt = {"EXPR", __tostring = deref} local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring} - local comment_mt = {"COMMENT", __fennelview = deref, __tostring = deref} + local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref} local sequence_marker = {"SEQUENCE"} local vararg = setmetatable({"..."}, {"VARARG", __fennelview = deref, __tostring = deref}) local getenv = nil @@ -3320,9 +3526,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function list(...) return setmetatable({...}, list_mt) end - local function sym(str, scope, source) - local s = {str, scope = scope} - for k, v in pairs((source or {})) do + local function sym(str, _3fsource, _3fscope) + local s = {str, ["?scope"] = _3fscope} + for k, v in pairs((_3fsource or {})) do if (type(k) == "string") then s[k] = v end @@ -3336,8 +3542,11 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function expr(strcode, etype) return setmetatable({strcode, type = etype}, expr_mt) end - local function comment_2a(contents) - return setmetatable({contents}, comment_mt) + local function comment_2a(contents, _3fsource) + local _1_ = (_3fsource or {}) + local filename = _1_["filename"] + local line = _1_["line"] + return setmetatable({contents, filename = filename, line = line}, comment_mt) end local function varg() return vararg @@ -3354,9 +3563,6 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function sym_3f(x) return ((type(x) == "table") and (getmetatable(x) == symbol_mt) and x) end - local function table_3f(x) - return ((type(x) == "table") and (x ~= vararg) and (getmetatable(x) ~= list_mt) and (getmetatable(x) ~= symbol_mt) and x) - end local function sequence_3f(x) local mt = ((type(x) == "table") and getmetatable(x)) return (mt and (mt.sequence == sequence_marker) and x) @@ -3364,6 +3570,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function comment_3f(x) return ((type(x) == "table") and (getmetatable(x) == comment_mt) and x) end + local function table_3f(x) + return ((type(x) == "table") and (x ~= vararg) and (getmetatable(x) ~= list_mt) and (getmetatable(x) ~= symbol_mt) and not comment_3f(x) and x) + end local function multi_sym_3f(str) if sym_3f(str) then return multi_sym_3f(tostring(str)) @@ -3450,7 +3659,7 @@ local compiler = require("fennel.compiler") local specials = require("fennel.specials") local repl = require("fennel.repl") local view = require("fennel.view") -local function get_env(env) +local function eval_env(env) if (env == "_COMPILER") then local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) local mt = getmetatable(env0) @@ -3460,26 +3669,32 @@ local function get_env(env) return (env and specials["wrap-env"](env)) end end -local function eval(str, options, ...) +local function eval_opts(options, str) local opts = utils.copy(options) - local _ = nil if ((opts.allowedGlobals == nil) and not getmetatable(opts.env)) then opts.allowedGlobals = specials["current-global-names"](opts.env) - _ = nil - else - _ = nil end - local env = get_env(opts.env) + 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, options, ...) + local opts = eval_opts(options, str) + local env = eval_env(opts.env) local lua_source = compiler["compile-string"](str, opts) local loader = nil - local function _1_(...) + local function _0_(...) if opts.filename then return ("@" .. opts.filename) else return str end end - loader = specials["load-code"](lua_source, env, _1_(...)) + loader = specials["load-code"](lua_source, env, _0_(...)) opts.filename = nil return loader(...) end @@ -3491,7 +3706,7 @@ local function dofile_2a(filename, options, ...) opts.filename = filename return eval(source, opts, ...) end -local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], 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"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.8.0", view = view} +local mod = {["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-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], 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"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.1-dev", view = view} utils["fennel-module"] = mod do local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other @@ -3504,7 +3719,7 @@ do ;; TODO: some of these macros modify their arguments; we should stop doing that, ;; but in a way that preserves file/line metadata. - (fn -> [val ...] + (fn ->* [val ...] "Thread-first macro. Take the first value and splice it into the second form as its first argument. The value of the second form is spliced into the first arg of the third, etc." @@ -3515,7 +3730,7 @@ do (set x elt))) x) - (fn ->> [val ...] + (fn ->>* [val ...] "Thread-last macro. Same as ->, except splices the value into the last position of each form rather than the first." @@ -3526,7 +3741,7 @@ do (set x elt))) x) - (fn -?> [val ...] + (fn -?>* [val ...] "Nil-safe thread-first macro. Same as -> except will short-circuit with nil when it encounters a nil value." (if (= 0 (select "#" ...)) @@ -3541,7 +3756,7 @@ do (-?> ,el ,(unpack els)) ,tmp))))) - (fn -?>> [val ...] + (fn -?>>* [val ...] "Nil-safe thread-last macro. Same as ->> except will short-circuit with nil when it encounters a nil value." (if (= 0 (select "#" ...)) @@ -3556,7 +3771,14 @@ do (-?>> ,el ,(unpack els)) ,tmp))))) - (fn doto [val ...] + (fn ?dot [tbl k ...] + "Nil-safe table look up. + Same as . (dot), except will short-circuit with nil when it encounters + a nil value in any of subsequent keys." + (if (= nil k) tbl `(let [res# (. ,tbl ,k)] + (and res# (?. res# ,...))))) + + (fn doto* [val ...] "Evaluates val and splices it into the first argument of subsequent forms." (let [name (gensym) form `(let [,name ,val])] @@ -3566,28 +3788,32 @@ do (table.insert form name) form)) - (fn when [condition body1 ...] + (fn when* [condition body1 ...] "Evaluate body for side-effects only when condition is truthy." (assert body1 "expected body") `(if ,condition - (do ,body1 ,...))) + (do + ,body1 + ,...))) - (fn with-open [closable-bindings ...] + (fn with-open* [closable-bindings ...] "Like `let`, but invokes (v:close) on each binding after evaluating the body. The body is evaluated inside `xpcall` so that bound values will be closed upon encountering an error before propagating it." - (let [bodyfn `(fn [] ,...) - closer `(fn close-handlers# [ok# ...] (if ok# ... - (error ... 0))) + (let [bodyfn `(fn [] + ,...) + closer `(fn close-handlers# [ok# ...] + (if ok# ... (error ... 0))) traceback `(. (or package.loaded.fennel debug) :traceback)] - (for [i 1 (# closable-bindings) 2] + (for [i 1 (length closable-bindings) 2] (assert (sym? (. closable-bindings i)) "with-open only allows symbols in bindings") (table.insert closer 4 `(: ,(. closable-bindings i) :close))) - `(let ,closable-bindings ,closer - (close-handlers# (xpcall ,bodyfn ,traceback))))) + `(let ,closable-bindings + ,closer + (close-handlers# (xpcall ,bodyfn ,traceback))))) - (fn collect [iter-tbl key-value-expr ...] + (fn collect* [iter-tbl key-value-expr ...] "Returns a table made by running an iterator and evaluating an expression that returns key-value pairs to be inserted sequentially into the table. This can be thought of as a \"table comprehension\". The provided key-value @@ -3600,8 +3826,7 @@ do {:red \"apple\" :orange \"orange\"}" (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2)) "expected iterator binding table") - (assert (not= nil key-value-expr) - "expected key-value expression") + (assert (not= nil key-value-expr) "expected key-value expression") (assert (= nil ...) "expected exactly one body expression. Wrap multiple expressions with do") `(let [tbl# {}] @@ -3610,7 +3835,7 @@ do (k# v#) (tset tbl# k# v#))) tbl#)) - (fn icollect [iter-tbl value-expr ...] + (fn icollect* [iter-tbl value-expr ...] "Returns a sequential table made by running an iterator and evaluating an expression that returns values to be inserted sequentially into the table. This can be thought of as a \"list comprehension\". @@ -3621,8 +3846,7 @@ do [9 16 25]" (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2)) "expected iterator binding table") - (assert (not= nil value-expr) - "expected table value expression") + (assert (not= nil value-expr) "expected table value expression") (assert (= nil ...) "expected exactly one body expression. Wrap multiple expressions with do") `(let [tbl# []] @@ -3630,13 +3854,15 @@ do (tset tbl# (+ (length tbl#) 1) ,value-expr)) tbl#)) - (fn partial [f ...] + (fn partial* [f ...] "Returns a function with all arguments partially applied to f." + (assert f "expected a function to partially apply") (let [body (list f ...)] (table.insert body _VARARG) - `(fn [,_VARARG] ,body))) + `(fn [,_VARARG] + ,body))) - (fn pick-args [n f] + (fn pick-args* [n f] "Creates a function of arity n that applies its arguments to f. For example, @@ -3644,12 +3870,14 @@ do expands to (fn [_0_ _1_] (func _0_ _1_))" (assert (and (= (type n) :number) (= n (math.floor n)) (>= n 0)) - "Expected n to be an integer literal >= 0.") + (.. "Expected n to be an integer literal >= 0, got " (tostring n))) (let [bindings []] - (for [i 1 n] (tset bindings i (gensym))) - `(fn ,bindings (,f ,(unpack bindings))))) + (for [i 1 n] + (tset bindings i (gensym))) + `(fn ,bindings + (,f ,(unpack bindings))))) - (fn pick-values [n ...] + (fn pick-values* [n ...] "Like the `values` special, but emits exactly n values. For example, @@ -3658,14 +3886,16 @@ do (let [(_0_ _1_) ...] (values _0_ _1_))" (assert (and (= :number (type n)) (>= n 0) (= n (math.floor n))) - "Expected n to be an integer >= 0") - (let [let-syms (list) - let-values (if (= 1 (select :# ...)) ... `(values ,...))] - (for [i 1 n] (table.insert let-syms (gensym))) + (.. "Expected n to be an integer >= 0, got " (tostring n))) + (let [let-syms (list) + let-values (if (= 1 (select "#" ...)) ... `(values ,...))] + (for [i 1 n] + (table.insert let-syms (gensym))) (if (= n 0) `(values) - `(let [,let-syms ,let-values] (values ,(unpack let-syms)))))) + `(let [,let-syms ,let-values] + (values ,(unpack let-syms)))))) - (fn lambda [...] + (fn lambda* [...] "Function literal with arity checking. Will throw an exception if a declared argument is passed in as nil, unless that argument name begins with ?." @@ -3673,23 +3903,25 @@ do has-internal-name? (sym? (. args 1)) arglist (if has-internal-name? (. args 2) (. args 1)) docstring-position (if has-internal-name? 3 2) - has-docstring? (and (> (# args) docstring-position) + has-docstring? (and (> (length args) docstring-position) (= :string (type (. args docstring-position)))) arity-check-position (- 4 (if has-internal-name? 0 1) (if has-docstring? 0 1)) - empty-body? (< (# args) arity-check-position)] + empty-body? (< (length args) arity-check-position)] (fn check! [a] (if (table? a) (each [_ a (pairs a)] (check! a)) (let [as (tostring a)] - (and (not (as:match "^?")) (not= as "&") (not= as "_") (not= as "..."))) + (and (not (as:match "^?")) (not= as "&") (not= as "_") + (not= as "..."))) (table.insert args arity-check-position `(assert (not= nil ,a) (string.format "Missing argument %s on %s:%s" ,(tostring a) - ,(or a.filename "unknown") + ,(or a.filename :unknown) ,(or a.line "?")))))) + (assert (= :table (type arglist)) "expected arg list") (each [_ a (ipairs arglist)] (check! a)) @@ -3697,27 +3929,27 @@ do (table.insert args (sym :nil))) `(fn ,(unpack args)))) - (fn macro [name ...] + (fn macro* [name ...] "Define a single macro." (assert (sym? name) "expected symbol for macro name") (local args [...]) - `(macros { ,(tostring name) (fn ,(unpack args))})) + `(macros {,(tostring name) (fn ,(unpack args))})) - (fn macrodebug [form return?] + (fn macrodebug* [form return?] "Print the resulting form after performing macroexpansion. With a second argument, returns expanded form as a string instead of printing." (let [handle (if return? `do `print)] `(,handle ,(view (macroexpand form _SCOPE))))) - (fn import-macros [binding1 module-name1 ...] + (fn import-macros* [binding1 module-name1 ...] "Binds a table of macros from each macro module according to a binding form. Each binding form can be either a symbol or a k/v destructuring table. Example: (import-macros mymacros :my-macros ; bind to symbol {:macro1 alias : macro2} :proj.macros) ; import by name" - (assert (and binding1 module-name1 (= 0 (% (select :# ...) 2))) + (assert (and binding1 module-name1 (= 0 (% (select "#" ...) 2))) "expected even number of binding/modulename pairs") - (for [i 1 (select :# binding1 module-name1 ...) 2] + (for [i 1 (select "#" binding1 module-name1 ...) 2] (let [(binding modname) (select i binding1 module-name1 ...) ;; generate a subscope of current scope, use require-macros ;; to bring in macro module. after that, we just copy the @@ -3727,10 +3959,10 @@ do (_SPECIALS.require-macros `(require-macros ,modname) subscope {} ast) (if (sym? binding) ;; bind whole table of macros to table bound to symbol - (do (tset scope.macros (. binding 1) {}) - (each [k v (pairs subscope.macros)] - (tset (. scope.macros (. binding 1)) k v))) - + (do + (tset scope.macros (. binding 1) {}) + (each [k v (pairs subscope.macros)] + (tset (. scope.macros (. binding 1)) k v))) ;; 1-level table destructuring for importing individual macros (table? binding) (each [macro-name [import-key] (pairs binding)] @@ -3757,16 +3989,26 @@ do (let [condition `(and (= (type ,val) :table)) bindings []] (each [k pat (pairs pattern)] - (if (and (sym? pat) (= "&" (tostring pat))) - (do (assert (not (. pattern (+ k 2))) - "expected rest argument before last parameter") - (table.insert bindings (. pattern (+ k 1))) - (table.insert bindings [`(select ,k ((or table.unpack - _G.unpack) - ,val))])) - (and (= :number (type k)) - (= "&" (tostring (. pattern (- k 1))))) - nil ; don't process the pattern right after &; already got it + (if (= pat `&) + (do + (assert (= nil (. pattern (+ k 2))) + "expected & rest argument before last parameter") + (table.insert bindings (. pattern (+ k 1))) + (table.insert bindings + [`(select ,k ((or table.unpack _G.unpack) ,val))])) + (= k `&as) + (do + (table.insert bindings pat) + (table.insert bindings val)) + (and (= :number (type k)) (= `&as pat)) + (do + (assert (= nil (. pattern (+ k 2))) + "expected &as argument before last parameter") + (table.insert bindings (. pattern (+ k 1))) + (table.insert bindings val)) + ;; don't process the pattern right after &/&as; already got it + (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 unifications)] @@ -3784,11 +4026,9 @@ do ;; 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 (in-scope? pattern) - (= :nil (tostring pattern)))) - (and (multi-sym? pattern) - (in-scope? (. (multi-sym? pattern) 1)))) + (not= "_" (tostring pattern)) ; never unify _ + (or (in-scope? pattern) (= :nil (tostring pattern)))) + (and (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))) @@ -3797,18 +4037,17 @@ do (sym? pattern) (let [wildcard? (: (tostring pattern) :find "^_")] (if (not wildcard?) (tset unifications (tostring pattern) val)) - (values (if (or wildcard? (string.find (tostring pattern) "^?")) - true `(not= ,(sym :nil) ,val)) - [pattern val])) + (values (if (or wildcard? (string.find (tostring pattern) "^?")) true + `(not= ,(sym :nil) ,val)) [pattern val])) ;; guard clause - (and (list? pattern) (sym? (. pattern 2)) (= :? (tostring (. pattern 2)))) + (and (list? pattern) (= (. pattern 2) `?)) (let [(pcondition bindings) (match-pattern vals (. pattern 1) unifications) condition `(and ,pcondition)] - (for [i 3 (# pattern)] ; splice in guard clauses + (for [i 3 (length pattern)] ; splice in guard clauses (table.insert condition (. pattern i))) - (values `(let ,bindings ,condition) bindings)) - + (values `(let ,bindings + ,condition) bindings)) ;; multi-valued patterns (represented as lists) (list? pattern) (match-values vals pattern unifications match-pattern) @@ -3821,14 +4060,15 @@ do (fn match-condition [vals clauses] "Construct the actual `if` AST for the given match values and clauses." (if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default - (table.insert clauses (length clauses) (sym :_))) + (table.insert clauses (length clauses) (sym "_"))) (let [out `(if)] (for [i 1 (length clauses) 2] (let [pattern (. clauses i) body (. clauses (+ i 1)) (condition bindings) (match-pattern vals pattern {})] (table.insert out condition) - (table.insert out `(let ,bindings ,body)))) + (table.insert out `(let ,bindings + ,body)))) out)) (fn match-val-syms [clauses] @@ -3841,22 +4081,101 @@ do (tset syms valnum (gensym)))))) syms)) - (fn match [val ...] - "Perform pattern matching on val. See reference for details." + (fn match* [val ...] + ;; Old implementation of match macro, which doesn't directly support + ;; `where' and `or'. New syntax is implemented in `match-where', + ;; which simply generates old syntax and feeds it to `match*'. (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)))) + (list `let [vals val] (match-condition vals clauses)))) - {: -> : ->> : -?> : -?>> - : doto : when : with-open - : collect : icollect - : partial : lambda - : pick-args : pick-values - : macro : macrodebug : import-macros - : match} + ;; Construction of old match syntax from new syntax + + (fn partition-2 [seq] + ;; Partition `seq` by 2. + ;; If `seq` has odd amount of elements, the last one is dropped. + ;; + ;; Input: [1 2 3 4 5] + ;; Output: [[1 2] [3 4]] + (let [firsts [] + seconds [] + res []] + (for [i 1 (length seq) 2] + (let [first (. seq i) + second (. seq (+ i 1))] + (table.insert firsts (if (not= nil first) first `nil)) + (table.insert seconds (if (not= nil second) second `nil)))) + (each [i v1 (ipairs firsts)] + (let [v2 (. seconds i)] + (if (not= nil v2) + (table.insert res [v1 v2])))) + res)) + + (fn transform-or [[_ & pats] guards] + ;; Transforms `(or pat pats*)` lists into match `guard` patterns. + ;; + ;; (or pat1 pat2), guard => [(pat1 ? guard) (pat2 ? guard)] + (let [res []] + (each [_ pat (ipairs pats)] + (table.insert res (list pat `? (unpack guards)))) + res)) + + (fn transform-cond [cond] + ;; Transforms `where` cond into sequence of `match` guards. + ;; + ;; pat => [pat] + ;; (where pat guard) => [(pat ? guard)] + ;; (where (or pat1 pat2) guard) => [(pat1 ? guard) (pat2 ? guard)] + (if (and (list? cond) (= (. cond 1) `where)) + (let [second (. cond 2)] + (if (and (list? second) (= (. second 1) `or)) + (transform-or second [(unpack cond 3)]) + :else + [(list second `? (unpack cond 3))])) + :else + [cond])) + + (fn match-where [val ...] + "Perform pattern matching on val. See reference for details. + + Syntax: + + (match data-expression + pattern body + (where pattern guard guards*) body + (where (or pattern patterns*) guard guards*) body)" + (let [conds-bodies (partition-2 [...]) + else-branch (if (not= 0 (% (select "#" ...) 2)) + (select (select "#" ...) ...)) + match-body []] + (each [_ [cond body] (ipairs conds-bodies)] + (each [_ cond (ipairs (transform-cond cond))] + (table.insert match-body cond) + (table.insert match-body body))) + (if else-branch + (table.insert match-body else-branch)) + (match* val (unpack match-body)))) + + {:-> ->* + :->> ->>* + :-?> -?>* + :-?>> -?>>* + :?. ?dot + :doto doto* + :when when* + :with-open with-open* + :collect collect* + :icollect icollect* + :partial partial* + :lambda lambda* + :pick-args pick-args* + :pick-values pick-values* + :macro macro* + :macrodebug macrodebug* + :import-macros import-macros* + :match match-where} ]===] local module_name = "fennel.macros" local _ = nil diff --git a/lib/multimethod.fnl b/lib/multimethod.fnl new file mode 100644 index 0000000..4ca7aac --- /dev/null +++ b/lib/multimethod.fnl @@ -0,0 +1,18 @@ +(local util (require :lib.util)) + +(local mm {}) + +(fn mm.__call [{: module : name} ...] + (let [dispatcher (. mm.dispatchers module name) + key (dispatcher ...) + method (or (. mm.methods module name key) (. mm.methods module name :default))] + (method ...))) + +(fn mm.defmulti [dispatcher name module] + (util.nested-tset mm [:dispatchers module name] dispatcher) + (setmetatable {: module : name} mm)) + +(fn mm.defmethod [{: module : name} key method] + (util.nested-tset mm [:methods module name key] method)) + +mm diff --git a/lib/util.fnl b/lib/util.fnl index 28ad1fc..db73734 100644 --- a/lib/util.fnl +++ b/lib/util.fnl @@ -53,6 +53,16 @@ (fn swappable-require [modname] (swappable (require modname))) +(fn hot-table [modname] + (local tbl {}) + (fn find-table [] + (let [loaded-pkg (. package.loaded modname)] + (if (= (type loaded-pkg) :table) loaded-pkg tbl))) + (setmetatable {:hot tbl} { + :__index (fn [_ key] (. (find-table) key)) + :__newindex (fn [_ key val] (tset (find-table) key val)) + })) + (fn readjson [filename] (local f (io.open filename :r)) (local text (f:read "*a")) @@ -64,11 +74,6 @@ (f:write (json.encode value)) (f:close)) -(fn file-exists [name] - (let [f (io.open name :r)] - (when (not= f nil) (io.close f)) - (not= f nil))) - (fn waitfor [pred] (local coro (coroutine.running)) (core.add_thread @@ -81,8 +86,33 @@ (fn in-coro [f ...] (-> (coroutine.create f) (coroutine.resume ...))) +(fn multival-next [multival i] + (when (< i multival.n) + (values (+ i 1) (. multival (+ i 1))))) + +(fn multival-ipairs [multival] + (values multival-next multival 0)) + +(fn multival [...] + (local multival {:n (select :# ...) :ipairs multival-ipairs}) + (for [i 1 multival.n] + (tset multival i (select i ...))) + multival) + +(fn nested-tset [t keys value] + (let [next-key (. keys 1)] + (if (= (length keys) 1) (tset t next-key value) + (do (when (= (. t next-key) nil) + (tset t next-key {})) + (nested-tset (. t next-key) (lume.slice keys 2) value))))) + +(fn file-exists [name] + (let [f (io.open name :r)] + (when (not= f nil) (io.close f)) + (not= f nil))) + {: int8-to-bytes : int16-to-bytes : int24-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24 : splice : lo : hi - : reload : hotswap : swappable :require swappable-require - : readjson : writejson : file-exists : waitfor : in-coro} + : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset + : readjson : writejson : file-exists : waitfor : in-coro : multival}