Updated to align with 0.9.0

This commit is contained in:
Alexander Griffith 2021-04-13 23:23:36 -04:00
commit 854e0897e3
6 changed files with 138 additions and 516 deletions

View file

@ -1038,8 +1038,32 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return _0_, not multi, 3 return _0_, not multi, 3
else else
return nil, true, 2 return nil, true, 2
<<<<<<< HEAD
end end
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)"
=======
>>>>>>> technomancy/min-love2d-fennel-0.9.0
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
local function compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, local_3f, arg_name_list, arg_list, docstring) 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 for i = (index + 1), #ast do
compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)}) compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)})
@ -1547,6 +1571,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
_0_ = 1 _0_ = 1
else else
_0_ = nil _0_ = nil
<<<<<<< HEAD
end end
subexprs = compiler.compile1(ast[i], scope, parent, {nval = _0_}) subexprs = compiler.compile1(ast[i], scope, parent, {nval = _0_})
utils.map(subexprs, tostring, operands) utils.map(subexprs, tostring, operands)
@ -1566,6 +1591,27 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local function _0_(...) local function _0_(...)
return arithmetic_special((lua_name or name), zero_arity, unary_prefix, ...) return arithmetic_special((lua_name or name), zero_arity, unary_prefix, ...)
end end
=======
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
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
>>>>>>> technomancy/min-love2d-fennel-0.9.0
SPECIALS[name] = _0_ SPECIALS[name] = _0_
return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.") return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.")
end end
@ -2376,7 +2422,18 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
if ((se.type == "expression") and (se[1] ~= "nil")) then if ((se.type == "expression") and (se[1] ~= "nil")) then
emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
elseif (se.type == "statement") then elseif (se.type == "statement") then
<<<<<<< HEAD
emit(chunk, disambiguate_parens(tostring(se), chunk), ast) emit(chunk, disambiguate_parens(tostring(se), chunk), ast)
=======
local code = tostring(se)
local unambiguous_code = nil
if (code:byte() == 40) then
unambiguous_code = ("; " .. code)
else
unambiguous_code = code
end
emit(chunk, unambiguous_code, ast)
>>>>>>> technomancy/min-love2d-fennel-0.9.0
end end
end end
return nil return nil
@ -3847,7 +3904,11 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
opts.filename = filename opts.filename = filename
return eval(source, opts, ...) return eval(source, opts, ...)
end end
<<<<<<< HEAD
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", 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", 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.0", view = view}
>>>>>>> technomancy/min-love2d-fennel-0.9.0
utils["fennel-module"] = mod utils["fennel-module"] = mod
do do
local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other

View file

@ -898,6 +898,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
else else
return nil, true, 2 return nil, true, 2
end 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 end
local function compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, local_3f, arg_name_list, arg_list, docstring) 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 for i = (index + 1), #ast do
@ -2235,7 +2245,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
if ((se.type == "expression") and (se[1] ~= "nil")) then if ((se.type == "expression") and (se[1] ~= "nil")) then
emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
elseif (se.type == "statement") then elseif (se.type == "statement") then
emit(chunk, disambiguate_parens(tostring(se), chunk), ast) local code = tostring(se)
local unambiguous_code = nil
if (code:byte() == 40) then
unambiguous_code = ("; " .. code)
else
unambiguous_code = code
end
emit(chunk, unambiguous_code, ast)
end end
end end
return nil return nil
@ -3706,19 +3723,19 @@ local function dofile_2a(filename, options, ...)
opts.filename = filename opts.filename = filename
return eval(source, opts, ...) return eval(source, opts, ...)
end end
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", 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.0", view = view}
utils["fennel-module"] = mod utils["fennel-module"] = mod
do do
local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other
;; modules that are loaded by the old bootstrap compiler, this runs in the ;; modules that are loaded by the old bootstrap compiler, this runs in the
;; compiler scope of the version of the compiler being defined. ;; compiler scope of the version of the compiler being defined.
;; The code for these macros is somewhat idiosyncratic because it cannot use any ;; The code for these macros is somewhat idiosyncratic because it cannot use any
;; macros which have not yet been defined. ;; macros which have not yet been defined.
;; TODO: some of these macros modify their arguments; we should stop doing that, ;; TODO: some of these macros modify their arguments; we should stop doing that,
;; but in a way that preserves file/line metadata. ;; but in a way that preserves file/line metadata.
(fn ->* [val ...] (fn ->* [val ...]
"Thread-first macro. "Thread-first macro.
Take the first value and splice it into the second form as its first argument. Take the first value and splice it into the second form as its first argument.
@ -3729,7 +3746,7 @@ do
(table.insert elt 2 x) (table.insert elt 2 x)
(set x elt))) (set x elt)))
x) x)
(fn ->>* [val ...] (fn ->>* [val ...]
"Thread-last macro. "Thread-last macro.
Same as ->, except splices the value into the last position of each form Same as ->, except splices the value into the last position of each form
@ -3740,7 +3757,7 @@ do
(table.insert elt x) (table.insert elt x)
(set x elt))) (set x elt)))
x) x)
(fn -?>* [val ...] (fn -?>* [val ...]
"Nil-safe thread-first macro. "Nil-safe thread-first macro.
Same as -> except will short-circuit with nil when it encounters a nil value." Same as -> except will short-circuit with nil when it encounters a nil value."
@ -3755,7 +3772,7 @@ do
(if ,tmp (if ,tmp
(-?> ,el ,(unpack els)) (-?> ,el ,(unpack els))
,tmp))))) ,tmp)))))
(fn -?>>* [val ...] (fn -?>>* [val ...]
"Nil-safe thread-last macro. "Nil-safe thread-last macro.
Same as ->> except will short-circuit with nil when it encounters a nil value." Same as ->> except will short-circuit with nil when it encounters a nil value."
@ -3770,14 +3787,14 @@ do
(if ,tmp (if ,tmp
(-?>> ,el ,(unpack els)) (-?>> ,el ,(unpack els))
,tmp))))) ,tmp)))))
(fn ?dot [tbl k ...] (fn ?dot [tbl k ...]
"Nil-safe table look up. "Nil-safe table look up.
Same as . (dot), except will short-circuit with nil when it encounters Same as . (dot), except will short-circuit with nil when it encounters
a nil value in any of subsequent keys." a nil value in any of subsequent keys."
(if (= nil k) tbl `(let [res# (. ,tbl ,k)] (if (= nil k) tbl `(let [res# (. ,tbl ,k)]
(and res# (?. res# ,...))))) (and res# (?. res# ,...)))))
(fn doto* [val ...] (fn doto* [val ...]
"Evaluates val and splices it into the first argument of subsequent forms." "Evaluates val and splices it into the first argument of subsequent forms."
(let [name (gensym) (let [name (gensym)
@ -3787,7 +3804,7 @@ do
(table.insert form elt)) (table.insert form elt))
(table.insert form name) (table.insert form name)
form)) form))
(fn when* [condition body1 ...] (fn when* [condition body1 ...]
"Evaluate body for side-effects only when condition is truthy." "Evaluate body for side-effects only when condition is truthy."
(assert body1 "expected body") (assert body1 "expected body")
@ -3795,7 +3812,7 @@ do
(do (do
,body1 ,body1
,...))) ,...)))
(fn with-open* [closable-bindings ...] (fn with-open* [closable-bindings ...]
"Like `let`, but invokes (v:close) on each binding after evaluating the body. "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 The body is evaluated inside `xpcall` so that bound values will be closed upon
@ -3812,13 +3829,13 @@ do
`(let ,closable-bindings `(let ,closable-bindings
,closer ,closer
(close-handlers# (xpcall ,bodyfn ,traceback))))) (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 "Returns a table made by running an iterator and evaluating an expression
that returns key-value pairs to be inserted sequentially into the table. 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 This can be thought of as a \"table comprehension\". The provided key-value
expression must return either 2 values, or nil. expression must return either 2 values, or nil.
For example, For example,
(collect [k v (pairs {:apple \"red\" :orange \"orange\"})] (collect [k v (pairs {:apple \"red\" :orange \"orange\"})]
(values v k)) (values v k))
@ -3834,12 +3851,12 @@ do
(match ,key-value-expr (match ,key-value-expr
(k# v#) (tset tbl# k# v#))) (k# v#) (tset tbl# k# v#)))
tbl#)) 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 "Returns a sequential table made by running an iterator and evaluating an
expression that returns values to be inserted sequentially into the table. expression that returns values to be inserted sequentially into the table.
This can be thought of as a \"list comprehension\". This can be thought of as a \"list comprehension\".
For example, For example,
(icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v))) (icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v)))
returns returns
@ -3853,7 +3870,7 @@ do
(each ,iter-tbl (each ,iter-tbl
(tset tbl# (+ (length tbl#) 1) ,value-expr)) (tset tbl# (+ (length tbl#) 1) ,value-expr))
tbl#)) tbl#))
(fn partial* [f ...] (fn partial* [f ...]
"Returns a function with all arguments partially applied to f." "Returns a function with all arguments partially applied to f."
(assert f "expected a function to partially apply") (assert f "expected a function to partially apply")
@ -3861,10 +3878,10 @@ do
(table.insert body _VARARG) (table.insert body _VARARG)
`(fn [,_VARARG] `(fn [,_VARARG]
,body))) ,body)))
(fn pick-args* [n f] (fn pick-args* [n f]
"Creates a function of arity n that applies its arguments to f. "Creates a function of arity n that applies its arguments to f.
For example, For example,
(pick-args 2 func) (pick-args 2 func)
expands to expands to
@ -3876,10 +3893,10 @@ do
(tset bindings i (gensym))) (tset bindings i (gensym)))
`(fn ,bindings `(fn ,bindings
(,f ,(unpack bindings))))) (,f ,(unpack bindings)))))
(fn pick-values* [n ...] (fn pick-values* [n ...]
"Like the `values` special, but emits exactly n values. "Like the `values` special, but emits exactly n values.
For example, For example,
(pick-values 2 ...) (pick-values 2 ...)
expands to expands to
@ -3894,7 +3911,7 @@ do
(if (= n 0) `(values) (if (= n 0) `(values)
`(let [,let-syms ,let-values] `(let [,let-syms ,let-values]
(values ,(unpack let-syms)))))) (values ,(unpack let-syms))))))
(fn lambda* [...] (fn lambda* [...]
"Function literal with arity checking. "Function literal with arity checking.
Will throw an exception if a declared argument is passed in as nil, unless Will throw an exception if a declared argument is passed in as nil, unless
@ -3921,26 +3938,26 @@ do
,(tostring a) ,(tostring a)
,(or a.filename :unknown) ,(or a.filename :unknown)
,(or a.line "?")))))) ,(or a.line "?"))))))
(assert (= :table (type arglist)) "expected arg list") (assert (= :table (type arglist)) "expected arg list")
(each [_ a (ipairs arglist)] (each [_ a (ipairs arglist)]
(check! a)) (check! a))
(if empty-body? (if empty-body?
(table.insert args (sym :nil))) (table.insert args (sym :nil)))
`(fn ,(unpack args)))) `(fn ,(unpack args))))
(fn macro* [name ...] (fn macro* [name ...]
"Define a single macro." "Define a single macro."
(assert (sym? name) "expected symbol for macro name") (assert (sym? name) "expected symbol for macro name")
(local args [...]) (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. "Print the resulting form after performing macroexpansion.
With a second argument, returns expanded form as a string instead of printing." With a second argument, returns expanded form as a string instead of printing."
(let [handle (if return? `do `print)] (let [handle (if return? `do `print)]
`(,handle ,(view (macroexpand form _SCOPE))))) `(,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. "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. Each binding form can be either a symbol or a k/v destructuring table.
@ -3971,9 +3988,9 @@ do
(tostring modname))) (tostring modname)))
(tset scope.macros import-key (. subscope.macros macro-name)))))) (tset scope.macros import-key (. subscope.macros macro-name))))))
nil) nil)
;;; Pattern matching ;;; Pattern matching
(fn match-values [vals pattern unifications match-pattern] (fn match-values [vals pattern unifications match-pattern]
(let [condition `(and) (let [condition `(and)
bindings []] bindings []]
@ -3984,7 +4001,7 @@ do
(each [_ b (ipairs subbindings)] (each [_ b (ipairs subbindings)]
(table.insert bindings b)))) (table.insert bindings b))))
(values condition bindings))) (values condition bindings)))
(fn match-table [val pattern unifications match-pattern] (fn match-table [val pattern unifications match-pattern]
(let [condition `(and (= (type ,val) :table)) (let [condition `(and (= (type ,val) :table))
bindings []] bindings []]
@ -4016,7 +4033,7 @@ do
(each [_ b (ipairs subbindings)] (each [_ b (ipairs subbindings)]
(table.insert bindings b))))) (table.insert bindings b)))))
(values condition bindings))) (values condition bindings)))
(fn match-pattern [vals pattern unifications] (fn match-pattern [vals pattern unifications]
"Takes the AST of values and a single pattern and returns a condition "Takes the AST of values and a single pattern and returns a condition
to determine if it matches as well as a list of bindings to to determine if it matches as well as a list of bindings to
@ -4056,7 +4073,7 @@ do
(match-table val pattern unifications match-pattern) (match-table val pattern unifications match-pattern)
;; literal value ;; literal value
(values `(= ,val ,pattern) [])))) (values `(= ,val ,pattern) []))))
(fn match-condition [vals clauses] (fn match-condition [vals clauses]
"Construct the actual `if` AST for the given match values and 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 (if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default
@ -4070,7 +4087,7 @@ do
(table.insert out `(let ,bindings (table.insert out `(let ,bindings
,body)))) ,body))))
out)) out))
(fn match-val-syms [clauses] (fn match-val-syms [clauses]
"How many multi-valued clauses are there? return a list of that many gensyms." "How many multi-valued clauses are there? return a list of that many gensyms."
(let [syms (list (gensym))] (let [syms (list (gensym))]
@ -4080,7 +4097,7 @@ do
(if (not (. syms valnum)) (if (not (. syms valnum))
(tset syms valnum (gensym)))))) (tset syms valnum (gensym))))))
syms)) syms))
(fn match* [val ...] (fn match* [val ...]
;; Old implementation of match macro, which doesn't directly support ;; Old implementation of match macro, which doesn't directly support
;; `where' and `or'. New syntax is implemented in `match-where', ;; `where' and `or'. New syntax is implemented in `match-where',
@ -4090,9 +4107,9 @@ do
;; protect against multiple evaluation of the value, bind against as ;; protect against multiple evaluation of the value, bind against as
;; many values as we ever match against in the clauses. ;; 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))))
;; Construction of old match syntax from new syntax ;; Construction of old match syntax from new syntax
(fn partition-2 [seq] (fn partition-2 [seq]
;; Partition `seq` by 2. ;; Partition `seq` by 2.
;; If `seq` has odd amount of elements, the last one is dropped. ;; If `seq` has odd amount of elements, the last one is dropped.
@ -4112,7 +4129,7 @@ do
(if (not= nil v2) (if (not= nil v2)
(table.insert res [v1 v2])))) (table.insert res [v1 v2]))))
res)) res))
(fn transform-or [[_ & pats] guards] (fn transform-or [[_ & pats] guards]
;; Transforms `(or pat pats*)` lists into match `guard` patterns. ;; Transforms `(or pat pats*)` lists into match `guard` patterns.
;; ;;
@ -4121,7 +4138,7 @@ do
(each [_ pat (ipairs pats)] (each [_ pat (ipairs pats)]
(table.insert res (list pat `? (unpack guards)))) (table.insert res (list pat `? (unpack guards))))
res)) res))
(fn transform-cond [cond] (fn transform-cond [cond]
;; Transforms `where` cond into sequence of `match` guards. ;; Transforms `where` cond into sequence of `match` guards.
;; ;;
@ -4136,12 +4153,12 @@ do
[(list second `? (unpack cond 3))])) [(list second `? (unpack cond 3))]))
:else :else
[cond])) [cond]))
(fn match-where [val ...] (fn match-where [val ...]
"Perform pattern matching on val. See reference for details. "Perform pattern matching on val. See reference for details.
Syntax: Syntax:
(match data-expression (match data-expression
pattern body pattern body
(where pattern guard guards*) body (where pattern guard guards*) body
@ -4157,7 +4174,7 @@ do
(if else-branch (if else-branch
(table.insert match-body else-branch)) (table.insert match-body else-branch))
(match* val (unpack match-body)))) (match* val (unpack match-body))))
{:-> ->* {:-> ->*
:->> ->>* :->> ->>*
:-?> -?>* :-?> -?>*

View file

@ -1,382 +0,0 @@
local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6}
local function sort_keys(_0_0, _1_0)
local _1_ = _0_0
local a = _1_[1]
local _2_ = _1_0
local b = _2_[1]
local ta = type(a)
local tb = type(b)
if ((ta == tb) and ((ta == "string") or (ta == "number"))) then
return (a < b)
else
local dta = type_order[ta]
local dtb = type_order[tb]
if (dta and dtb) then
return (dta < dtb)
elseif dta then
return true
elseif dtb then
return false
else
return (ta < tb)
end
end
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") or (k ~= i)) then
assoc_3f = true
end
i = (i + 1)
insert(kv, {k, v})
end
table.sort(kv, sort_keys)
if (#kv == 0) then
return kv, "empty"
else
local function _2_()
if assoc_3f then
return "table"
else
return "seq"
end
end
return kv, _2_()
end
end
local function count_table_appearances(t, appearances)
if (type(t) == "table") then
if not appearances[t] then
appearances[t] = 1
for k, v in pairs(t) do
count_table_appearances(k, appearances)
count_table_appearances(v, appearances)
end
else
appearances[t] = ((appearances[t] or 0) + 1)
end
end
return appearances
end
local function save_table(t, seen)
local seen0 = (seen or {len = 0})
local id = (seen0.len + 1)
if not seen0[t] then
seen0[t] = id
seen0.len = id
end
return seen0
end
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
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)))
end
local function table_indent(t, indent, id)
local opener_length = nil
if id then
opener_length = (#tostring(id) + 2)
else
opener_length = 1
end
return (indent + opener_length)
end
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
local function _2_()
if ("seq" == table_type) then
return "["
else
return "{"
end
end
open = ((prefix or "") .. _2_())
local close = nil
if ("seq" == table_type) then
close = "]"
else
close = "}"
end
local oneline = (open .. table.concat(elements, " ") .. close)
if (not options["one-line?"] and (multiline_3f or ((indent + #oneline) > options["line-length"]))) then
return (open .. table.concat(elements, indent_str) .. close)
else
return oneline
end
end
local function pp_associative(t, kv, options, indent, key_3f)
local multiline_3f = false
local id = options.seen[t]
if (options.level >= options.depth) then
return "{...}"
elseif (id and options["detect-cycles?"]) then
return ("@" .. id .. "{...}")
else
local visible_cycle_3f0 = visible_cycle_3f(t, options)
local id0 = (visible_cycle_3f0 and options.seen[t])
local indent0 = table_indent(t, indent, id0)
local slength = nil
local function _3_()
local _2_0 = rawget(_G, "utf8")
if _2_0 then
return _2_0.len
else
return _2_0
end
end
local function _4_(_241)
return #_241
end
slength = ((options["utf8?"] and _3_()) or _4_)
local prefix = nil
if visible_cycle_3f0 then
prefix = ("@" .. id0)
else
prefix = ""
end
local items = nil
do
local tbl_0_ = {}
for _, _6_0 in pairs(kv) do
local _7_ = _6_0
local k = _7_[1]
local v = _7_[2]
local _8_
do
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
items = tbl_0_
end
return concat_table_lines(items, options, multiline_3f, indent0, "table", prefix)
end
end
local function pp_sequence(t, kv, options, indent)
local multiline_3f = false
local id = options.seen[t]
if (options.level >= options.depth) then
return "[...]"
elseif (id and options["detect-cycles?"]) then
return ("@" .. id .. "[...]")
else
local visible_cycle_3f0 = visible_cycle_3f(t, options)
local id0 = (visible_cycle_3f0 and options.seen[t])
local indent0 = table_indent(t, indent, id0)
local prefix = nil
if visible_cycle_3f0 then
prefix = ("@" .. id0)
else
prefix = ""
end
local items = nil
do
local tbl_0_ = {}
for _, _3_0 in pairs(kv) do
local _4_ = _3_0
local _0 = _4_[1]
local v = _4_[2]
local _5_
do
local v0 = pp(v, options, indent0)
multiline_3f = (multiline_3f or v0:find("\n"))
_5_ = v0
end
tbl_0_[(#tbl_0_ + 1)] = _5_
end
items = tbl_0_
end
return concat_table_lines(items, options, multiline_3f, indent0, "seq", prefix)
end
end
local function concat_lines(lines, options, indent, force_multi_line_3f)
if (#lines == 0) then
if options["empty-as-sequence?"] then
return "[]"
else
return "{}"
end
else
local oneline = nil
local _2_
do
local tbl_0_ = {}
for _, line in ipairs(lines) do
tbl_0_[(#tbl_0_ + 1)] = line:gsub("^%s+", "")
end
_2_ = tbl_0_
end
oneline = table.concat(_2_, " ")
if (not options["one-line?"] and (force_multi_line_3f or oneline:find("\n") or ((indent + #oneline) > options["line-length"]))) then
return table.concat(lines, ("\n" .. string.rep(" ", indent)))
else
return oneline
end
end
end
local function pp_metamethod(t, metamethod, options, indent)
if (options.level >= options.depth) then
if options["empty-as-sequence?"] then
return "[...]"
else
return "{...}"
end
else
local _ = nil
local function _2_(_241)
return visible_cycle_3f(_241, options)
end
options["visible-cycle?"] = _2_
_ = nil
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
return lines
elseif (_3_0 == "table") then
return concat_lines(lines, options, indent, force_multi_line_3f)
else
local _0 = _3_0
return error("__fennelview metamethod must return a table of lines")
end
end
end
local function pp_table(x, options, indent)
options.level = (options.level + 1)
local x0 = nil
do
local _2_0 = nil
if options["metamethod?"] then
local _3_0 = x
if _3_0 then
local _4_0 = getmetatable(_3_0)
if _4_0 then
_2_0 = _4_0.__fennelview
else
_2_0 = _4_0
end
else
_2_0 = _3_0
end
else
_2_0 = nil
end
if (nil ~= _2_0) then
local metamethod = _2_0
x0 = pp_metamethod(x, metamethod, options, indent)
else
local _ = _2_0
local _4_0, _5_0 = table_kv_pairs(x)
if (true and (_5_0 == "empty")) then
local _0 = _4_0
if options["empty-as-sequence?"] then
x0 = "[]"
else
x0 = "{}"
end
elseif ((nil ~= _4_0) and (_5_0 == "table")) then
local kv = _4_0
x0 = pp_associative(x, kv, options, indent)
elseif ((nil ~= _4_0) and (_5_0 == "seq")) then
local kv = _4_0
x0 = pp_sequence(x, kv, options, indent)
else
x0 = nil
end
end
end
options.level = (options.level - 1)
return x0
end
local function number__3estring(n)
local _2_0 = string.gsub(tostring(n), ",", ".")
return _2_0
end
local function colon_string_3f(s)
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 = {["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
end
for k, v in pairs(overrides) do
defaults[k] = v
end
return defaults
end
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 _4_()
local _3_0 = getmetatable(x)
if _3_0 then
return _3_0.__fennelview
else
return _3_0
end
end
if ((tv == "table") or ((tv == "userdata") and _4_())) then
return pp_table(x, options0, indent0)
elseif (tv == "number") then
return number__3estring(x)
else
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(x, make_options(x, options), 0)
end
return view

View file

@ -1,27 +1,29 @@
(require "love.event") (require "love.event")
(local view (require "lib.fennelview")) (local {: view} (require :lib.fennel))
;; This module exists in order to expose stdio over a channel so that it ;; This module exists in order to expose stdio over a channel so that it
;; can be used in a non-blocking way from another thread. ;; can be used in a non-blocking way from another thread.
(local (event channel) ...) (local (event channel) ...)
(fn prompt [next-line?]
(io.write (if next-line? ".." ">> ")) (io.flush) (.. (io.read) "\n"))
(when channel (when channel
(let [prompt (fn [next-line?] (io.write (if next-line? ".." ">> ")) (io.flush) (.. (io.read) "\n"))] ((fn looper [input]
((fn looper [input] (when input
(when input ;; This is consumed by love.handlers[event]
;; This is consumed by love.handlers[event] (love.event.push event input)
(love.event.push event input) (let [output (: channel :demand)
(let [output (: channel :demand) next-line (and (. output 2) (= "next-line" (. output 2)))]
next-line (and (. output 2) (= "next-line" (. output 2)))] ;; There is probably a more efficient way of determining an error
;; There is probably a more efficient way of determining an error (if next-line :ok
(if next-line :ok (and (. output 2) (= "Error:" (. output 2)))
(and (. output 2) (= "Error:" (. output 2))) (print (view output))
(print (view output)) (each [_ ret (ipairs output)]
(each [_ ret (ipairs output)] (print ret)))
(print ret))) (io.flush)
(io.flush) (looper (prompt next-line))))) (prompt)))
(looper (prompt next-line))))) (prompt))))
{:start (fn start-repl [] {:start (fn start-repl []
(let [code (love.filesystem.read "lib/stdio.fnl") (let [code (love.filesystem.read "lib/stdio.fnl")

View file

@ -1,76 +0,0 @@
require("love.event")
local view = require("lib.fennelview") local event, channel = ...
if channel then local prompt = nil local function _0_(next_line_3f) local function _1_() if next_line_3f then return ".." else return ">> " end end io.write(_1_()) io.flush() return (io.read() .. "\n") end prompt = _0_ local function looper(input) if input then love.event.push(event, input) local output = channel:demand() local next_line = (output[2] and ("next-line" == output[2])) if next_line then elseif (output[2] and ("Error:" == output[2])) then print(view(output)) else for _, ret in ipairs(output) do print(ret) end end io.flush() return looper(prompt(next_line)) end end looper(prompt()) end local function start_repl() local code = love.filesystem.read("lib/stdio.fnl") local luac = nil if code then luac = love.filesystem.newFileData(fennel.compileString(code), "io") else luac = love.filesystem.read("lib/stdio.lua") end local thread = love.thread.newThread(luac) local io_channel = love.thread.newChannel() local coro = coroutine.create(fennel.repl) local out = nil local function _2_(val) return io_channel:push(val) end out = _2_ local options = nil local function _3_(kind, ...) return out({kind, "Error:", ...}) end local function _4_(parser_state) if (parser_state["stack-size"] > 0) then io_channel:push({"next-line", "next-line"}) end return coroutine.yield() end options = {moduleName = "lib.fennel", onError = _3_, onValues = out, pp = view, readChunk = _4_} coroutine.resume(coro, options) thread:start("eval", io_channel) local function _5_(input) return coroutine.resume(coro, input) end love.handlers.eval = _5_ return nil end return {start = start_repl}

View file

@ -1,7 +1,7 @@
-- bootstrap the compiler -- bootstrap the compiler
fennel = require("lib.fennel") fennel = require("lib.fennel")
table.insert(package.loaders, fennel.make_searcher({correlate=true})) table.insert(package.loaders, fennel.make_searcher({correlate=true}))
pp = function(x) print(require("lib.fennelview")(x)) end pp = function(x) print(fennel.view(x)) end
lume = require("lib.lume") lume = require("lib.lume")
require("wrap") require("wrap")