Module:Wikilisp
Documentation for this module may be created at Module:Wikilisp/doc
local export = {}
local wikilispversion = "0.19 (November 4, 2019)"
--[[ some basic abstractions ]]
local function stype( x ) -- type of sexpr
local t = type( x )
if t == "table" then t = x.type end
return t
end
local function seterr( x, ... )
if type(x) ~= "table" then
return seterr( {}, x, ... )
else
x.type = "error"
x.msg = mw.ustring.format( ... )
return x
end
end
--[[ parse text to a sequence of sexprs ]]
local function tok3( ls, t )
-- tokenize lua string t, with no string literals comments or parens;
-- append to ls
local p1,p2 = mw.ustring.find( t, "[^%s]+" )
while p1 ~= nil do
local t1 = mw.ustring.sub(t, p1, p2)
local n1 = tonumber(t1)
if n1 ~= nil then
ls[1 + #ls] = n1
elseif t1 == "true" then
ls[1 + #ls] = true
elseif t1 == "false" then
ls[1 + #ls] = false
else
ls[1 + #ls] = {
type = "symbol",
name = t1
}
end
t = mw.ustring.sub(t, (p2 + 1))
p1,p2 = mw.ustring.find( t, "[^%s]+" )
end
end
local function tok2( ls, t )
-- tokenize lua string t, with no string literals or comments; append to ls
local p1 = mw.ustring.find( t, "[()\\]" )
while p1 ~= nil do
tok3( ls, mw.ustring.sub(t, 1, (p1 - 1)) )
ls[1 + #ls] = { type = mw.ustring.sub(t, p1, p1) }
if ls[#ls].type == "\\" then
ls[#ls].name = ls[#ls].type
ls[#ls].type = "symbol"
end
t = mw.ustring.sub(t, (p1 + 1))
p1 = mw.ustring.find( t, "[()\\]" )
end
tok3( ls, t )
end
local function tok1( ls, t )
-- tokenize lua string t, thru first string literal or comment; append to ls
-- if not finished, append untokenized remainder string and return true
local p0 = mw.ustring.find( t, ';' )
local p1 = mw.ustring.find( t, '"' )
local p2 = mw.ustring.find( t, "'" )
if (p0 ~= nil) and (((p1 == nil) or (p0 < p1)) and
((p2 == nil) or (p0 < p2))) then
-- process a comment
tok2( ls, mw.ustring.sub( t, 1, (p0 - 1) ) )
p1 = mw.ustring.find( t, '\n', (p0 + 1) )
if p1 == nil then
return false
else
ls[1 + #ls] = mw.ustring.sub( t, (p1 + 1) )
return true
end
elseif (p1 ~= nil) and ((p2 == nil) or (p1 < p2)) then
-- process a string literal starting with double-quote
p2 = p1 + 1
while true do
p2 = mw.ustring.find( t, '"', p2 )
if p2 == nil then
seterr(ls, 'mismatched string-literal delimiter (")')
return false
elseif (p2 < mw.ustring.len( t )) and
(mw.ustring.codepoint( t, (p2 + 1) ) == 34)
then
p2 = (p2 + 2)
else
tok2( ls, mw.ustring.sub( t, 1, (p1 - 1) ) )
ls[1 + #ls] = mw.ustring.gsub(
mw.ustring.sub( t, (p1 + 1), (p2 - 1) ),
'""', '"') -- inverse operation is at write_sexpr
ls[1 + #ls] = mw.ustring.sub( t, (p2 + 1) )
return true
end
end
elseif p2 ~= nil then
-- process a string literal starting with single-quote
-- side benefit: precludes Lisp shorthand for "suppress eval"
p1 = p2
p2 = mw.ustring.find( t, "'", (p1 + 1) )
if p2 == nil then
seterr(ls, "mismatched string-literal delimiter (')")
return false
else
tok2( ls, mw.ustring.sub( t, 1, (p1 - 1) ) )
ls[1 + #ls] = mw.ustring.sub( t, (p1 + 1), (p2 - 1) )
ls[1 + #ls] = mw.ustring.sub( t, (p2 + 1) )
return true
end
else
tok2( ls, t )
return false
end
end
local function parse_next( x1, p1, x2 )
-- parse one sexpr from token list x1 position p1, append sexpr to p2
-- return new value for p1
if stype(x1[p1]) == ")" then
seterr(x2, "unmatched right-paren")
return 1 + #x1
elseif stype(x1[p1]) ~= "(" then
x2[1 + #x2] = x1[p1]
return p1 + 1
else
p1 = p1 + 1
local x3 = { type = "list" }
x2[1 + #x2] = x3
while p1 <= #x1 do
if stype(x1[p1]) == ")" then
return p1 + 1
end
p1 = parse_next( x1, p1, x3 )
end
seterr(x2, "unmatched left-paren")
return p1
end
end
local function parse_sexpr( x1 )
-- x1 is an error or a list of tokens
if x1.type ~= "list" then
return x1
else
local p1 = 1 --next item to read from x1
local x2 = { type = "list" }
while p1 <= #x1 do
p1 = parse_next( x1, p1, x2 )
end
return x2
end
end
local function text_to_sexpr( t )
local ls = { type = "list" }
while tok1( ls, t ) do
t = ls[#ls]
ls[#ls] = nil
end
ls = parse_sexpr( ls )
return ls
end
--[[ write/display a sexpr ]]
local function write_sexpr( x )
if type(x) == "number" then
return tostring( x )
elseif type(x) == "string" then
return mw.ustring.format('"%s"', mw.ustring.gsub( x, '"', '""' )) -- inverse operation is at tok1
elseif type(x) == "boolean" then
if x then return "true" else return "false" end
elseif type(x) ~= "table" then
return mw.ustring.format("<unrecognized internal type: %s>", type(x))
elseif x.type == "symbol" then
return x.name
elseif x.type == "fn" then
return mw.ustring.format("<%s>", write_sexpr( x.comb ))
elseif x.type == "op" then
if x.name ~= nil then
return mw.ustring.format("[op: %s]", x.name)
else
return "[op]"
end
elseif x.type == "list" then
local r = {}
r[1] = "("
for k = 1, #x do
r[k+1] = write_sexpr( x[k] )
end
r[#r + 1] = ")"
return table.concat(r, " ")
elseif x.type == "error" then
return mw.ustring.format("<error: %s>", x.msg)
elseif x.type == "pattern" then
return mw.ustring.format('<pattern: "%s">', x.pat)
elseif x.type ~= nil then
return mw.ustring.format("<unrecognized type: %s>", x.type)
else
return "<missing type>"
end
end
local function display_sexpr( x )
if stype(x) == "string" then
return x
else
return write_sexpr( x )
end
end
--[[ evaluation tools ]]
local maxdepth = 4 -- maximum call-nesting depth
local combine
local function eval( x, env, depth )
if type(x) ~= "table" then -- literal
return x
elseif x.type == "symbol" then
local v = env[x.name]
if v == nil then
return seterr("undefined symbol: %s", x.name)
else
return v
end
elseif x.type ~= "list" then -- literal
return x
elseif #x == 0 then -- empty list
return x
else -- combination
local c = eval( x[1], env, depth )
if stype(c) == "error" then return c end
local ls = { type = "list" }
for k = 2, #x do
ls[k - 1] = x[k]
end
return combine( c, ls, env, depth )
end
end
combine = function( c, ls, env, depth )
while stype(c) == "fn" do
local ls2 = { type = "list" }
for k = 1, #ls do
ls2[k] = eval( ls[k], env, depth )
if stype(ls2[k]) == "error" then return ls2[k] end
end
c = c.comb
ls = ls2
end
if stype(c) ~= "op" then
return seterr("called object is not a combiner: %s", write_sexpr(c))
elseif (c.shallow ~= nil) then
return c.op(ls, env, depth)
elseif (depth == nil) or (depth < 1) then
if maxdepth > 1 then
return seterr(
"exceeded maximum call-nesting depth (%i)",
maxdepth)
else
return seterr("exceeded maximum call-nesting depth")
end
else
return c.op(ls, env, (depth - 1))
end
end
local function eval_seq( ls, env, depth )
-- ls must be an error or a list
if ls.type == "error" then return ls end
if #ls == 0 then return ls end
for k = 1, (#ls - 1) do
local x = eval( ls[k], env, depth )
if stype(x) == "error" then return x end
end
return eval( ls[#ls], env, depth )
end
local function eval_all( ls, env, depth, cutoff )
-- ls must be an error or a list
if ls.type == "error" then return ls end
local ls2 = { type="list" }
for k = 1, #ls do
ls2[k] = eval( ls[k], env, depth )
if stype(ls2[k]) == "error" then return ls2[k] end
if (cutoff ~= nil) and cutoff(ls2[k]) then return ls2 end
end
return ls2
end
local function combine_all( ops, args, env, depth, cutoff )
-- ops must be a list; args must be an error or a list
if args.type == "error" then return args end
local ls2 = { type="list" }
for k = 1, #ops do
ls2[k] = combine( ops[k], args, env, depth )
if stype(ls2[k]) == "error" then return ls2[k] end
if (cutoff ~= nil) and cutoff(ls2[k]) then return ls2 end
end
return ls2
end
--[[ generic combiner constructors ]]
local function make_op( f, nm, sh )
return {
type = "op",
op = f,
name = nm,
shallow = sh
}
end
local function checktype( t, o, k ) -- types list, operands list, index
if #t == 0 then return "" end
o = o[k] -- particular operand
if k > #t then k = #t end
t = t[k] -- particular type
-- t should now be a string or internal function
if type(t) == "string" then
if stype(o) == t then t = "" end -- clear if no error
else
t = t(o) -- assume internal function works correctly
end
-- t should now be type name if error, empty string if okay
return t
end
local function type_err( cname, tname, x )
-- combiner name, type name(s), operand
-- type name may be a string or an array of strings
local where = ""
if cname ~= nil then where = " to [op: " .. cname .. "]" end
if type(tname) == "table" then
if #tname == 0 then tname = "[unknown]"
else
for k = 1, #tname do
while tname[k] == "" do
for j = (k + 1), #tname do tname[j - 1] = tname[j] end
tname[#tname] = nil
end
if tname[k] ~= nil then
for j = (k + 1), #tname do
if tname[k] == tname[j] then tname[j] = "" end
end
end
end
if #tname == 1 then tname = tname[1]
else
tname[#tname] = "or " .. tname[#tname]
if #tname == 2
then tname = table.concat( tname, " " )
else tname = table.concat( tname, ", " )
end
end
end
end
local what = write_sexpr(x)
if #what > 64 then what = stype(x) end
return seterr(
"bad operand%s: expected %s, got %s", where, tname, what)
end
local function typed_op( ... )
-- alternating type (string or function) and op (table or function)
-- strong recommendation: first op should be a table
local ls0 = { ... }
local n0 = select( '#', ... )
local opname, shallow
if type(ls0[2]) == "table" then
opname = ls0[2].name
shallow = ls0[2].shallow
end
local f = function(ls, env, depth)
if #ls == 0 then
local op = ls0[2]
if type(op) == "table" then op = op.op end
return op( ls, env, depth )
end
local ek = 1 -- operand number of accumulated error type names
local enames = {} -- list of failed types for ls[ek]
for j = 1, n0, 2 do
local types = ls0[j]
local op = ls0[j + 1]
if type(op) == "table" then op = op.op end
local t = ""
for k = 1, #ls do
if #t == 0 then
t = checktype( types, ls, k )
if #t > 0 then
if k > ek then
ek = k
enames = { t }
elseif k == ek then
enames[1 + #enames] = t
end
end
end
end
if #t == 0 then return op( ls, env, depth ) end
end
return type_err( opname, enames, ls[ek] )
end
return make_op( f, opname, shallow )
end
local function nary_op( c, n, m )
local f = function(ls, env, depth)
if n < 0 then
if #ls < -n then
local where = ""
if c.name ~= nil then where = " to [op: " .. c.name .. "]" end
return seterr(
"too few operands%s: expected at least %i, got %i",
where, -n, #ls)
end
elseif m == nil then
if #ls ~= n then
local where = ""
if c.name ~= nil then where = " to [op: " .. c.name .. "]" end
return seterr(
"wrong number of operands%s: expected %i, got %i",
where, n, #ls)
end
else
if #ls < n then
local where = ""
if c.name ~= nil then where = " to [op: " .. c.name .. "]" end
return seterr(
"too few operands%s: expected at least %i, got %i",
where, n, #ls)
elseif #ls > m then
local where = ""
if c.name ~= nil then where = " to [op: " .. c.name .. "]" end
return seterr(
"too many operands%s: expected at most %i, got %i",
where, m, #ls)
end
end
return c.op( ls, env, depth )
end
return make_op( f, c.name, c.shallow )
end
local function binary_pred( test, nm )
return make_op(function (ls)
for k = 2, #ls do
if not test(ls[k - 1], ls[k]) then
return false
end
end
return true
end, nm, true)
end
local function unary_pred( test, nm )
return make_op(function (ls)
for k = 1, #ls do
if not test(ls[k]) then
return false
end
end
return true
end, nm, true)
end
local function wrap( c )
return {
type = "fn",
comb = c
}
end
--[[ wiki parsing stuff
entry: (char-code (first-pos last-pos left-index))
(descriptor (first-pos last-pos left-index) entry entry ...)
item entries contain part entries, part entries contain item entries
left-index is removed at end of parse
]]
local lsquare,rsquare, lcurly,rcurly, pipe = 91,93, 123,125, 124
local function wikileft(e) -- is entry a left-delimiter?
return ((e[1] == lsquare) or (e[1] == lcurly)) and (e[2][1] ~= e[2][2])
end
local function wikilen(e) -- how long is this entry?
return 1 + e[2][2] - e[2][1]
end
local function wikisub( m, d ) -- parse, descriptor
local k2 = #m -- index of right delimiter
local k1 = m[k2][2][3] -- index of left delimiter
local p = { type = "list", "part", { type = "list" } } -- first part
p[2][1] = (m[k1][2][2] + 1) -- start of first part
local e = { -- entry containing parts
type = "list",
d,
{ type = "list",
(m[k1][2][2] - (m[k2][2][2] - m[k2][2][1])),
m[k2][2][2],
k1
},
p
}
for k = (k1 + 1), (k2 - 1) do
if type(m[k][1]) ~= "number" then
m[k][2][3] = nil
p[1 + #p] = m[k]
elseif m[k][1] == pipe then
p[2][2] = (m[k][2][1] - 1) -- end of current part
p = { type = "list", "part", { type = "list" } } -- next part
p[2][1] = (m[k][2][2] + 1) -- start of this part
e[1 + #e] = p -- add to list of parts
end
m[k] = nil
end
p[2][2] = (m[k2][2][1] - 1) -- end of last part
m[k2] = nil
m[k1][2][2] = (e[2][1] - 1)
if (m[k1][2][1] > m[k1][2][2]) then
e[2][3] = m[k1][2][3]
m[k1] = nil
end
m[1 + #m] = e
end
local function parse_wiki( ls )
local s = ls[1] -- string to parse
local m = { type = "list" } -- result of parse
local k = mw.ustring.find( s, "[%[%]{}|]" ) -- position in string
while k ~= nil do
local c = mw.ustring.codepoint(s,k)
if #m == 0 then
if (c == lsquare) or (c == lcurly) then
m[1] = {type="list", c, {type="list", k, k, 0}}
end
elseif (k == (m[#m][2][2] + 1)) and (c == m[#m][1]) and (c ~= pipe) then
m[#m][2][2] = k
if m[#m][2][3] > 0 then
local e2 = m[#m]
local e1 = m[e2[2][3]]
if (e2[1] == rcurly) and (e1[1] == lcurly) and
(wikilen(e2) == 3) and (wikilen(e1) > 2)
then
wikisub( m, "param" )
elseif (e2[1] == rsquare) and (e1[1] == lsquare) and
(wikilen(e2) == 2) and (wikilen(e1) > 1)
then
wikisub( m, "link" )
end
end
else
if m[#m][2][3] > 0 then
local e2 = m[#m]
local e1 = m[e2[2][3]]
if (e2[1] == rcurly) and (e1[1] == lcurly) and
(wikilen(e2) == 2) and (wikilen(e1) > 1)
then
wikisub( m, "call" )
end
end
m[1 + #m] = {type="list", c, {type="list", k, k}}
if wikileft(m[#m - 1]) then
m[#m][2][3] = (#m - 1)
else
m[#m][2][3] = m[#m - 1][2][3]
end
end
k = mw.ustring.find( s, "[%[%]{}|]", (k + 1) )
end
if #m == 0 then return m end
if m[#m][2][3] > 0 then
local e2 = m[#m]
local e1 = m[e2[2][3]]
if (e2[1] == rcurly) and (e1[1] == lcurly) and
(wikilen(e2) == 2) and (wikilen(e1) > 1)
then
wikisub( m, "call" )
end
end
local m2 = { type = "list" }
for j = 1, #m do
if type(m[j][1]) ~= "number" then
m[j][2][3] = nil
m2[1 + #m2] = m[j]
end
end
return m2
end
--[[ miscellaneous ]]
local function int_tc(x)
if (type(x) ~= "number") or (x ~= math.floor(x)) then
return "integer"
else
return ""
end
end
local function posint_tc(x)
if (type(x) ~= "number") or (x ~= math.floor(x)) or (x < 1) then
return "positive integer"
else
return ""
end
end
local function logical_and( ls ) -- for and?
for k = 1, #ls do
if stype(ls[k]) ~= "boolean" then
return seterr(
"bad operand to [op: and?]: expected boolean, got %s",
write_sexpr(ls[k]))
end
end
for k = 1, #ls do if not ls[k] then return false end end
return true
end
local function logical_or( ls ) -- for or?
for k = 1, #ls do
if stype(ls[k]) ~= "boolean" then
return seterr(
"bad operand to [op: or?]: expected boolean, got %s",
write_sexpr(ls[k]))
end
end
for k = 1, #ls do if ls[k] then return true end end
return false
end
local function and_fn(ls, env, depth)
ls = eval_all( ls, env, depth,
function (x)
return (stype(x) == "boolean") and not x
end)
if stype(ls) == "error" then return ls end
if (#ls == 0) or (stype(ls[1]) == "boolean") then
return logical_and(ls)
end
local ops = { type="list" }
for k = 1, #ls do
if stype(ls[k]) == "fn" then ops[k] = ls[k].comb
elseif stype(ls[k]) == "op" then ops[k] = ls[k]
elseif k == 1 then
return seterr(
"bad operand to [op: and?]: expected boolean or combiner, got %s",
write_sexpr(ls[k]))
else
return seterr(
"bad operand to [op: and?]: expected combiner, got %s",
write_sexpr(ls[k]))
end
end
return wrap(make_op(function (ls, env, depth)
ls = combine_all(ops, ls, env, depth,
function (x)
return (stype(x) ~= "boolean") or not x
end)
if ls.type == "error" then return ls end
return logical_and(ls)
end, "and?", true))
end
local function or_fn(ls, env, depth)
ls = eval_all(ls, env, depth,
function (x)
return (stype(x) == "boolean") and x
end)
if stype(ls) == "error" then return ls end
if (#ls == 0) or (stype(ls[1]) == "boolean") then
return logical_or(ls)
end
local ops = { type="list" }
for k = 1, #ls do
if stype(ls[k]) == "fn" then ops[k] = ls[k].comb
elseif stype(ls[k]) == "op" then ops[k] = ls[k]
elseif k == 1 then
return seterr(
"bad operand to [op: or?]: expected boolean or combiner, got %s",
write_sexpr(ls[k]))
else
return seterr(
"bad operand to [op: or?]: expected combiner, got %s",
write_sexpr(ls[k]))
end
end
return wrap(make_op(function (ls, env, depth)
ls = combine_all(ops, ls, env, depth,
function (x)
return (stype(x) ~= "boolean") or x
end)
if ls.type == "error" then return ls end
return logical_or(ls)
end, "or?", true))
end
local function valid_parmlist( ls ) -- for \
if stype(ls) ~= "list" then return false end
for k = 1, #ls do
if stype(ls[k]) ~= "symbol" then return false end
end
return true
end
local function match_parmlist( parms, ls ) -- for \
local env = {}
for k = 1, #parms do env[parms[k].name] = ls[k] end
return env
end
local function lambda_fn(ls, senv)
local parms = ls[1]
if stype(parms) == "symbol" then
parms = { type="list", parms }
elseif not valid_parmlist(parms) then
return seterr(
"bad parameter-list operand to [op: \\]: %s",
write_sexpr(parms))
end
local body = { type = "list" }
for k = 2, #ls do body[k - 1] = ls[k] end
return wrap(nary_op(make_op(function (ls, denv, depth)
-- denv is ignored
local env = match_parmlist( parms, ls )
setmetatable(env, { __index = senv })
return eval_seq(body, env, depth)
end), #parms))
end
local relevantFrame = mw.getCurrentFrame()
local function getarg_fn(ls)
local args = relevantFrame.args
local t = nil
if stype(ls[1]) == "number" then
t = ls[1]
else -- must be number or string
t = ls[1]
end
t = args[t]
if t == nil then return { type = "list" } end
return t
end
local function getargexpr_fn(ls)
local args = relevantFrame.args
local t = nil
if stype(ls[1]) == "number" then
t = ls[1]
else -- must be number or string
t = ls[1]
end
t = args[t]
if t == nil then return { type = "list" } end
t = text_to_sexpr(t)
if stype(t) == "error" then return { type = "list" } end
if #t ~= 1 then return { type = "list" } end
return t[1]
end
local function filter_fn(ls, env, depth)
local preds = { type = "list" }
for k = 2, #ls do preds[k - 1] = ls[k].comb end -- predicates
local function hof(ls, n, f, app)
-- copy first n elements of ls, apply f to later elements
-- if app, instead skip first n, and return result,app
if app == nil then app = false end
local ls2 = { type = "list" }
if #ls <= n then
if app then return ls2,app else return ls end
end
if not app then for k = 1, n do ls2[k] = ls[k] end end
for k = (n + 1), #ls do
local x,app2 = f(ls[k])
if stype(x) == "error" then return x end
if app2 == nil then app2 = false end
if app2 then
for j = 1, #x do ls2[1 + #ls2] = x[j] end
else
ls2[1 + #ls2] = x
end
end
return ls2,app
end
local function filter_entry(entry)
local b = combine_all(preds, {type="list", entry}, env, depth,
function (x)
return (stype(x) ~= "boolean") or not x
end)
if stype(b) == "error" then return b end
b = logical_and(b)
if stype(b) == "error" then return b end
if b then
if stype(entry) == "list" then
return hof(entry, 2, function (part)
return hof(part, 2, filter_entry)
end)
else
return entry
end
else
if stype(entry) == "list" then
return hof(entry, 2, function (part)
return hof(part, 2, filter_entry, true)
end, true)
else
return { type = "list" }, true
end
end
end
return hof(ls[1], 0, filter_entry)
end
local function item_tc(x)
if (stype(x) == "list") and (#x > 1) and
(stype(x[1]) == "string") and (x[1] ~= "part") and
(stype(x[2]) == "list") and (#x[2] == 2) and
(int_tc(x[2][1]) == "") and (int_tc(x[2][2]) == "")
then
return ""
else
return "item"
end
end
local function part_tc(x)
if (stype(x) == "list") and (#x > 1) and (x[1] == "part") and
(stype(x[2]) == "list") and (#x[2] == 2) and
(int_tc(x[2][1]) == "") and (int_tc(x[2][2]) == "")
then
return ""
else
return "part"
end
end
local function cd_tc(x)
if (stype(x) == "list") and (#x > 0) then
if stype(x[1]) == "string" then x = x[2] end
if (x ~= nil) and (stype(x) == "list") and (#x == 2) and
(int_tc(x[1]) == "") and (int_tc(x[2]) == "")
then
return ""
end
end
return "coordinates descriptor"
end
local function cd_ls_tc(x)
local ok = true
if stype(x) ~= "list" then ok = false
else for k = 1, #x do if cd_tc(x[k]) ~= "" then ok = false end end
end
if ok then return ""
else return "list of coordinates descriptors"
end
end
local function getsubstr_ntv(s, k1, k2) -- k1, k2 ints if provided
if k1 == nil then return s end
if k1 < 1 then k1 = 1 end
if k2 ~= nil then
if k2 >= mw.ustring.len(s) then k2 = nil end
end
return mw.ustring.sub( s, k1, k2 )
end
local function cd_norm(x) -- assumes cd_tc
if stype(x[1]) == "number" then return x else return x[2] end
end
local function getsubstr_int_fn(ls)
local s = ls[1]
return getsubstr_ntv(s, ls[2], ls[3])
end
local function getsubstr_cd_fn(ls)
local s = ls[1]
local c = cd_norm(ls[2])
return getsubstr_ntv(s, c[1], c[2])
end
local function getsubstr_ls_fn(ls)
local s = ls[1]
local r = { type = "list" }
for k = 1, #ls[2] do
r[k] = cd_norm(ls[2][k])
end
for k = 1, #r do r[k] = getsubstr_ntv(s, r[k][1], r[k][2]) end
return r
end
local function setsubstr_ls(s, lsc, lss)
-- string, array of cds, array of strings
local n = math.min(#lsc, #lss) -- just ignore extras of either
if n == 0 then return s end
local function berr(...)
return seterr("bounds violation in [op: set-substring]: %s",
mw.ustring.format( ... ))
end
if lsc[1][1] < 1 then
return berr("segment starts left of string start (%i)", lsc[1][1])
end
if lsc[n][2] > mw.ustring.len(s) then
return berr("segment ends right of string end (%i, %i)",
lsc[n][2], mw.ustring.len(s))
end
local r = {}
for k = 1, n do
if lsc[k][1] > (lsc[k][2] + 1) then
return berr("segment starts right of its own end (%i, %i)",
lsc[k][1], lsc[k][2])
end
r[2 * k] = lss[k]
end
r[1] = mw.ustring.sub(s, 1, (lsc[1][1] - 1))
r[1 + (2 * n)] = mw.ustring.sub(s, (lsc[n][2] + 1))
for k = 2, n do
if lsc[k - 1][2] >= lsc[k][1] then
return berr("segment ends right of next segment start (%i, %i)",
lsc[k - 1][2], lsc[k][1])
end
r[(2 * k) - 1] = mw.ustring.sub(s,
(lsc[k - 1][2] + 1),
(lsc[k][1] - 1))
end
return table.concat(r)
end
local function str_ls_tc(x)
local ok = true
if stype(x) ~= "list" then ok = false
else for k = 1, #x do if stype(x[k]) ~= "string" then ok = false end end
end
if ok then return ""
else return "list of strings"
end
end
local function getsublist_fn(ls)
local n1 = ls[2]
local n2 = ls[3]
local ls = ls[1]
local x = { type = "list" }
if n1 < 1 then n1 = 1 end
if n2 == nil then n2 = #ls elseif n2 > #ls then ns = #ls end
for k = n1, n2 do x[1 + #x] = ls[k] end
return x
end
local function setsublist_fn(ls)
local base = ls[1]
local n1 = ls[2] - 1
local n2 = ls[3] + 1
local seg = ls[4]
if n1 < 0 then n1 = 0 end
if n2 <= n1 then n2 = n1 + 1 end
local r = { type = "list" }
for k = 1, n1 do r[k] = base[k] end
for k = 1, #seg do r[1 + #r] = seg[k] end
for k = n2, #base do r[1 + #r] = base[k] end
return r
end
local function findprd_fn(ls, env, depth)
local x = ls[1]
local p = ls[2].comb
local x2 = { type = "list" }
for k = 1, #x do
local q = combine( p, { type="list", x[k] }, env, depth )
if stype(q) == "error" then return q end
if stype(q) ~= "boolean" then
return seterr(
"bad predicate result type to [op: find]: got %s",
stype(q))
end
if q then x2[1 + #x2] = k end
end
return x2
end
local function findstr_fn(ls)
local s = ls[1]
local p = ls[2]
local x2 = { type = "list" }
if #p == 0 then return x2 end
local k = 1
repeat
local x3 = { mw.ustring.find( s, p, k, true ) }
if #x3 == 0 then return x2 end
x2[1 + #x2] = { type = "list", x3[1], x3[2] }
k = 1 + x3[2]
until false
end
local function findpat_fn(ls)
local s = ls[1]
local p = ls[2].pat
local x2 = { type = "list" }
local k = 1
repeat
local x3 = { mw.ustring.find( s, p, k ) }
if #x3 == 0 then return x2 end
x2[1 + #x2] = { type = "list", x3[1], x3[2] }
k = 1 + x3[2]
until false
end
local function any_tc(x) return "" end
local function none_tc(x) return "no operand here" end
local function member_fn(ls) -- 1 or 2 operands, second must be a list
local t = write_sexpr(ls[1])
if ls[2] ~= nil then
ls = ls[2]
for k = 1, #ls do
if write_sexpr(ls[k]) == t then return true end
end
return false
else
return wrap(nary_op(typed_op({ "list" }, make_op(function(ls)
ls = ls[1]
for k = 1, #ls do
if write_sexpr(ls[k]) == t then return true end
end
return false
end, nil, true)), 1))
end
end
local lang = mw.language.getContentLanguage()
local function let_tc(x)
if (stype(x) == "list") and (#x == 2) and (stype(x[1]) == "symbol")
then return ""
else return "symbol-value binding"
end
end
local function sorp_tc(x)
if (stype(x) == "string") or (stype(x) == "pattern")
then return ""
else return "string or pattern"
end
end
local function split_tc(x)
if (stype(x) == "list") and (#x >= 1) and (sorp_tc(x[1]) == "") and
((#x == 1) or
((#x == 2) and ((sorp_tc(x[2]) == "") or (split_tc(x[2]) == ""))) or
((#x == 3) and (sorp_tc(x[2]) == "") and (split_tc(x[3]) == "")))
then
return ""
else
return "valid string-split descriptor"
end
end
local function strnest_tc(x)
if stype(x) == "string" then return ""
elseif stype(x) == "list" then
for k = 1, #x do
local msg = strnest_tc(x[k])
if msg ~= "" then return msg end
end
return ""
end
return "string or tree of strings"
end
local function splitsep_fn(s, p)
local x
if (stype(p) == "string")
then x = mw.text.split( s, p, true )
else x = mw.text.split( s, p.pat )
end
x.type = "list"
return x
end
local function splitdelim_fn(s, lt, rt)
local lp = (stype(lt) == "string")
local rp = (stype(rt) == "string")
if not lp then lt = lt.pat end
if not rp then rt = rt.pat end
local snarf -- find next unmatched right-delimiter
snarf = function (k)
repeat
local xl = { mw.ustring.find( s, lt, k, lp ) }
local xr = { mw.ustring.find( s, rt, k, rp ) }
if #xr == 0 then return xr end
if #xl == 0 then return xr end
if xr[1] <= xl[1] then return xr end
xr = snarf(xl[2] + 1)
if #xr == 0 then return xr end
k = (xr[2] + 1)
until false
end
local results = { type = "list" }
local k = 1 -- leftmost character of interest
repeat
local xl = { mw.ustring.find( s, lt, k, lp ) }
if #xl == 0 then return results end
k = xl[2] + 1
local xr = snarf(k)
if #xr > 0 then
results[1 + #results] = mw.ustring.sub( s, k, (xr[1] - 1) )
k = xr[2] + 1
end
until false
end
local function splitrec_fn(s, rc)
local ls
if (#rc > 1) and (stype(rc[2]) ~= "list") then
ls = splitdelim_fn(s, rc[1], rc[2])
else
ls = splitsep_fn(s, rc[1])
end
ls.type = "list"
rc = rc[#rc]
if (stype(rc) == "list") then
for k = 1, #ls do
ls[k] = splitrec_fn(ls[k], rc)
end
end
return ls
end
local function splitnest_fn(s, rc)
if stype(s) == "string" then return splitrec_fn(s, rc) end
local result = { type="list" }
for k = 1, #s do
result[k] = splitnest_fn(s[k], rc)
if stype(result[k]) == "error" then return result[k] end
end
return result
end
local function split_fn(ls)
local rc = { type = "list" }
for k = 2, #ls do rc[k - 1] = ls[k] end
return splitnest_fn(ls[1], rc)
end
local function join_tc(x)
if (stype(x) == "list") and (#x >= 1) and (stype(x[1]) == "string") and
((#x == 1) or
((#x == 2) and ((stype(x[2]) == "string") or (join_tc(x[2]) == ""))) or
((#x == 3) and (stype(x[2]) == "string") and (join_tc(x[3]) == "")))
then
return ""
else
return "valid string-join descriptor"
end
end
local function neststr_tc(x)
if stype(x) == "list" then
for k = 1, #x do
if stype(x[k]) ~= "string" then
local msg = neststr_tc(x[k])
if msg ~= "" then return msg end
end
end
return ""
end
return "tree of strings"
end
local function joinsep_fn(t, s)
if #t == 0 then return "" end
if stype(t[1]) == "string" then
for k = 2, #t do if stype(t[k]) ~= "string" then
return seterr("bad target for [op: join]: uneven tree depth")
end end
return table.concat( t, s )
end
for k = 2, #t do if stype(t[k]) == "string" then
return seterr("bad target for [op: join]: uneven tree depth")
end end
local result = { type = "list" }
for k = 1, #t do
result[k] = joinsep_fn(t[k], s)
if stype(result[k]) == "error" then return result[k] end
end
return result
end
local function joindelim_fn(t, lf, rg)
if #t == 0 then return "" end
if stype(t[1]) == "string" then
for k = 2, #t do if stype(t[k]) ~= "string" then
return seterr("bad target for [op: join]: uneven tree depth")
end end
return lf .. table.concat( t, (rg .. lf) ) .. rg
end
for k = 2, #t do if stype(t[k]) == "string" then
return seterr("bad target for [op: join]: uneven tree depth")
end end
local result = { type = "list" }
for k = 1, #t do
result[k] = joindelim_fn(t[k], lf, rg)
if stype(result[k]) == "error" then return result[k] end
end
return result
end
local function joinnest_fn(t, rc)
if stype(t) == "error" then return t end
if stype(t) == "string" then
return seterr("bad target for [op: join]: tree not deep enough")
end
if #rc == 1 then
return joinsep_fn(t, rc[1])
elseif #rc == 3 then
return joinnest_fn(joindelim_fn(t, rc[1], rc[2]), rc[3])
elseif stype(rc[2]) == "string" then
return joindelim_fn(t, rc[1], rc[2])
else
return joinnest_fn(joinsep_fn(t, rc[1]), rc[2])
end
end
local function join_fn(ls)
local rc = { type = "list" }
for k = 2, #ls do rc[k - 1] = ls[k] end
return joinnest_fn(ls[1], rc)
end
local function xformer_fn(pred, basis, succ, n)
return wrap(nary_op(typed_op({ "fn", "fn", any_tc },
make_op(function (ls, denv, depth)
local leaf = ls[1]
local parent = ls[2]
local data = ls[3]
local function xform(basis, data)
local recurse = false
if stype(data) == "list" then
if stype(pred) ~= "fn" then
recurse = true
else
recurse = combine( pred.comb, { type="list", data }, env, depth )
if stype(recurse) ~= "boolean" then
if stype(recurse) == "error" then return recurse end
return seterr(
"bad predicate result type to [op transform]: %s",
stype(recurse))
end
end
end
local comb
if recurse then
local b2
if stype(succ) == "fn"
then b2 = combine( succ.comb, { type="list", basis }, env, depth )
else b2 = basis
end
local d2 = { type="list" }
for k = 1, #data do
if k <= n then
d2[k] = data[k]
else
d2[k] = xform(b2, data[k])
if stype(d2[k]) == "error" then return d2[k] end
end
end
data = d2
comb = parent.comb
else
comb = leaf.comb
end
if stype(succ) == "fn"
then data = { type="list", basis, data }
else data = { type="list", data }
end
return combine( comb, data, env, depth )
end
return xform(basis, data)
end, "transform", true)), 3))
end
--[[ standard environment ]]
local ground_env = {
list = wrap(make_op(function (ls) return ls end, "list", true)),
["+"] = wrap(typed_op(
{ "number" }, make_op(function (ls)
local sum = 0
for k = 1, #ls do sum = sum + ls[k] end
return sum
end, "add", true),
{ "string" }, function (ls)
local s = {}
for k = 1, #ls do s[k] = ls[k] end
return table.concat(s)
end,
{ "boolean" }, function (ls)
local sum = true
for k = 1, #ls do sum = sum and ls[k] end
return sum
end,
{ "list" }, function (ls)
local x = { type = "list" }
for j = 1, #ls do
for k = 1, #ls[j] do
x[1 + #x] = ls[j][k]
end
end
return x
end)),
["*"] = wrap(typed_op({ "number" }, make_op(function (ls)
local product = 1
for k = 1, #ls do product = product * ls[k] end
return product
end, "multiply", true))),
["-"] = wrap(nary_op(typed_op({ "number" }, make_op(function (ls)
local result = ls[1]
for k = 2, #ls do result = result - ls[k] end
return result
end, "subtract", true)), -2)),
["/"] = wrap(nary_op(typed_op({ "number" }, make_op(function (ls)
local result = ls[1]
for k = 2, #ls do result = result / ls[k] end
return result
end, "divide", true)), -2)),
["^"] = wrap(nary_op(typed_op({ "number" }, make_op(function (ls)
return ls[1] ^ ls[2]
end, "exponentiation", true)), 2)),
["\\"] = nary_op(make_op(lambda_fn, "\\", true), -1),
abs = wrap(nary_op(typed_op({ "number" }, make_op(function (ls)
return math.abs(ls[1])
end, "abs", true)), 1)),
anchorencode = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
return mw.uri.anchorEncode( ls[1] )
end, "anchorencode", true)), 1)),
["and?"] = make_op(and_fn, "and?", true),
apply = wrap(nary_op(typed_op(
{ "fn", "list" }, make_op(function (ls, env, depth)
return combine(ls[1].comb, ls[2], env, depth)
end, "apply", true)), 2)),
["boolean?"] = wrap(unary_pred(function (x)
return stype(x) == "boolean"
end, "boolean?")),
["call?"] = wrap(unary_pred(function (x)
return (stype(x) == "list") and (#x > 0) and
(stype(x[1]) == "string") and (x[1] == "call")
end, "call?")),
canonicalurl = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
if #ls == 1
then return tostring( mw.uri.canonicalUrl( ls[1] ) )
else return tostring( mw.uri.canonicalUrl( ls[1], ls[2] ) )
end
end, "canonicalurl", true)), 1, 2)),
ceil = wrap(nary_op(typed_op({ "number" }, make_op(function (ls)
return math.ceil(ls[1])
end, "ceil", true)), 1)),
curry = wrap(nary_op(typed_op(
{ "fn", any_tc }, make_op(function (ls1, env, depth)
return wrap(make_op(function (ls2, env, depth)
local ls3 = { type = "list" }
for k = 2, #ls1 do ls3[k - 1] = ls1[k] end
for k = 1, #ls2 do ls3[k + #ls1 - 1] = ls2[k] end
return combine(ls1[1].comb, ls3, env, depth)
end, nil, true))
end, "curry", true)), -2)),
define = nary_op(make_op(function (ls, env, depth)
if stype(ls[1]) ~= "symbol" then
return seterr(
"bad definiend to [op: define]: expected symbol, got %s",
write_sexpr(ls[1]))
end
local x = eval(ls[2], env, depth)
if stype(x) == "error" then return x end
env[ls[1].name] = x
while stype(x) == "fn" do x = x.comb end
if stype(x) == "op" and x.name == nil then x.name = ls[1].name end
return { type = "list" }
end, "define", true), 2),
["equal?"] = wrap(make_op(function (ls)
if #ls >= 2 then
local t = write_sexpr(ls[1])
for k = 2, #ls do
if write_sexpr(ls[k]) ~= t then
return false
end
end
end
return true
end, "equal?", true)),
filter = wrap(nary_op(typed_op({ "list", "fn" }, make_op(filter_fn,
"filter", true)), -1)),
find = wrap(nary_op(typed_op(
{ "list", "fn" }, make_op(findprd_fn, "find", true),
{ "string", "string" }, findstr_fn,
{ "string", "pattern" }, findpat_fn
), 2)),
floor = wrap(nary_op(typed_op({ "number" }, make_op(function (ls)
return math.floor(ls[1])
end, "floor", true)), 1)),
["fn?"] = wrap(unary_pred(function (x)
return stype(x) == "fn"
end, "fn?")),
fullurl = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
if #ls == 1
then return tostring( mw.uri.fullUrl( ls[1] ) )
else return tostring( mw.uri.fullUrl( ls[1], ls[2] ) )
end
end, "fullurl", true)), 1, 2)),
["ge?"] = wrap(typed_op(
{ "number" }, binary_pred(function (x1, x2) return x1 >= x2 end, "ge?"),
{ "string" }, binary_pred(function (x1, x2) return x1 >= x2 end))),
['get-arg'] = wrap(nary_op(typed_op(
{ "number" }, make_op(getarg_fn, "get-arg", true),
{ "string" }, getarg_fn), 1)),
['get-arg-expr'] = wrap(nary_op(typed_op(
{ "number" }, make_op(getargexpr_fn, "get-arg-expr", true),
{ "string" }, getargexpr_fn), 1)),
['get-args'] = nary_op(make_op(function ()
local ls = { type = "list" }
for v, k in pairs( relevantFrame.args ) do
ls[1 + #ls] = v
end
return ls
end, "get-args"), 0),
['get-coords'] = wrap(nary_op(typed_op({ cd_tc },make_op(function (ls)
ls = ls[1]
if stype(ls[1]) == "string" then ls = ls[2] end
return { type="list", ls[1], ls[2] }
end, "get-coords", true)), 1)),
["get-items"] = wrap(nary_op(typed_op({ part_tc }, make_op(function (ls)
ls = ls[1]
local ls2 = { type="list" }
for k = 3, #ls do ls2[k - 2] = ls[k] end
return ls2
end, "get-items", true)), 1)),
["get-parts"] = wrap(nary_op(typed_op({ item_tc }, make_op(function (ls)
ls = ls[1]
local ls2 = { type="list" }
for k = 3, #ls do ls2[k - 2] = ls[k] end
return ls2
end, "get-parts", true)), 1)),
["get-sublist"] = wrap(nary_op(typed_op(
{ "list", int_tc },
make_op(getsublist_fn, "get-sublist", true)), 2, 3)),
["get-substring"] = wrap(typed_op(
{ "string", int_tc },
nary_op(make_op(getsubstr_int_fn, "get-substring", true), 2, 3),
{ "string", cd_tc },
nary_op(make_op(getsubstr_cd_fn, "get-substring", true), 2),
{ "string", cd_ls_tc },
nary_op(make_op(getsubstr_ls_fn, "get-substring", true), 2))),
["gt?"] = wrap(typed_op(
{ "number" }, binary_pred(function (x1, x2) return x1 > x2 end, "gt?"),
{ "string" }, binary_pred(function (x1, x2) return x1 > x2 end))),
["if"] = nary_op(make_op(function (ls, env, depth)
local test = eval(ls[1], env, depth)
if stype(test) == "error" then return test end
if stype(test) ~= "boolean" then
return seterr(
"bad test-result in [op: if]: %s",
write_sexpr(test))
elseif test then
return eval(ls[2], env, depth)
else
return eval(ls[3], env, depth)
end
end, "if", true), 3),
join = wrap(typed_op(
{ neststr_tc, "string", join_tc },
nary_op(make_op(join_fn, "join", true), 2, 3),
{ neststr_tc, "string", "string", join_tc },
nary_op(make_op(join_fn, "split", true), 3, 4))),
lc = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
return lang:lc(ls[1])
end, "lc", true),
{ str_ls_tc }, function (ls)
ls = ls[1]
local r = { type = "list" }
for k = 1, #ls do r[k] = lang:lc(ls[k]) end
return r
end), 1)),
lcfirst = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
return lang:lcfirst(ls[1])
end, "lcfirst", true),
{ str_ls_tc }, function (ls)
ls = ls[1]
local r = { type = "list" }
for k = 1, #ls do r[k] = lang:lcfirst(ls[k]) end
return r
end), 1)),
["le?"] = wrap(typed_op(
{ "number" }, binary_pred(function (x1, x2) return x1 <= x2 end, "le?"),
{ "string" }, binary_pred(function (x1, x2) return x1 <= x2 end))),
length = wrap(nary_op(typed_op(
{ "list" }, make_op(function (ls)
return #ls[1]
end, "length", true),
{ "string" }, function (ls)
return mw.ustring.len( ls[1] )
end), 1)),
let = nary_op(typed_op({ let_tc, any_tc }, make_op(function (ls, env, depth)
local p = ls[1][1]
local v = eval( ls[1][2], env, depth )
if stype(v) == "error" then return v end
local body = { type = "list" }
for k = 2, #ls do body[k - 1] = ls[k] end
local e = {}
e[p.name] = v
setmetatable(e, { __index = env})
return eval_seq(body, e, depth)
end, "let", true)), -1),
["link?"] = wrap(unary_pred(function (x)
return (stype(x) == "list") and (#x > 0) and
(stype(x[1]) == "string") and (x[1] == "link")
end, "link?")),
["list?"] = wrap(unary_pred(function (x)
return stype(x) == "list"
end, "list?")),
["lt?"] = wrap(typed_op(
{ "number" }, binary_pred(function (x1, x2) return x1 < x2 end, "lt?"),
{ "string" }, binary_pred(function (x1, x2) return x1 < x2 end))),
map = wrap(nary_op(typed_op({ "fn", "list" }, make_op(
function (ls, env, depth)
local n = #ls[2]
for k = 3, #ls do if #ls[k] < n then n = #ls[k] end end
local x = { type = "list" }
for j = 1, n do
local x2 = { type = "list" }
for k = 2, #ls do x2[k - 1] = ls[k][j] end
x[j] = combine( ls[1].comb, x2, env, depth )
if stype(x[j]) == "error" then return x[j] end
end
return x
end, "map", true)), -2)),
["member?"] = wrap(nary_op(typed_op(
{ any_tc, "list" }, make_op(member_fn, "member?", true)), 1, 2)),
merge = wrap(nary_op(typed_op({ "fn", "list" }, make_op(
function (ls, env, depth)
local ks = {}
for k = 2, #ls do ks[k] = 1 end
local result = { type = "list" }
while true do
local j = nil
for k = 2, #ls do
if ks[k] <= #ls[k] then
if j == nil then j = k else
local x = combine( ls[1].comb,
{ ls[k][ks[k]], ls[j][ks[j]] }, env, depth )
if stype(x) == "error" then return x end
if x then j = k end
end
end
end
if j == nil then return result else
result[#result + 1] = ls[j][ks[j]]
ks[j] = ks[j] + 1
end
end
end, "merge", true)), -2)),
["not?"] = wrap(nary_op(typed_op({ "boolean" }, make_op(function (ls)
return not ls[1]
end, "not?", true)), 1)),
nth = wrap(nary_op(typed_op({ "list", posint_tc }, make_op(function (ls)
local x = ls[1]
for k = 2, #ls do
local n = ls[k]
if #x < n then
return seterr(
"bad index to [op: nth]: asked for %i, list length is %i",
n, #x)
end
x = x[n]
if (k < #ls) and (stype(x) ~= "list") then
return seterr("bad multi-index to [op: nth]: tree too shallow")
end
end
return x
end, "nth", true)), -2)),
["number?"] = wrap(unary_pred(function (x)
return stype(x) == "number"
end, "number?")),
["op?"] = wrap(unary_pred(function (x)
return stype(x) == "op"
end, "op?")),
["or?"] = make_op(or_fn, "or?", true),
["param?"] = wrap(unary_pred(function (x)
return (stype(x) == "list") and (#x > 0) and
(stype(x[1]) == "string") and (x[1] == "param")
end, "param?")),
parse = wrap(nary_op(typed_op({ "string" }, make_op(parse_wiki,
"parse", true)), 1)),
pattern = wrap(nary_op(typed_op({ "string" }, make_op(function (ls)
local p = ls[1]
if #p == 0 then p = "[^%z%Z]" end -- disable null pattern
return { type="pattern", pat=p }
end, "pattern", true)), 1)),
sequence = make_op(function (ls, env, depth)
return eval_seq(ls, env, depth)
end, "sequence", true),
["set-sublist"] = wrap(nary_op(typed_op(
{ "list", int_tc, int_tc, "list" },
make_op(setsublist_fn, "set-sublist", true)), 4)),
["set-substring"] = wrap(typed_op(
{ "string", int_tc, int_tc, "string" },
nary_op(make_op(function (ls)
return setsubstr_ls(ls[1], { { ls[2], ls[3] } }, { ls[4] })
end, "set-substring", true), 4),
{ "string", cd_tc, "string" },
nary_op(make_op(function (ls)
return setsubstr_ls(ls[1], { cd_norm(ls[2]) }, { ls[3] })
end, "set-substring", true), 3),
{ "string", cd_ls_tc, str_ls_tc },
nary_op(make_op(function (ls)
local lsc = {}
for k = 1, #ls[2] do lsc[k] = cd_norm(ls[2][k]) end
return setsubstr_ls(ls[1], lsc, ls[3])
end, "set-substring", true), 3)
)),
split = wrap(typed_op(
{ strnest_tc, sorp_tc, split_tc },
nary_op(make_op(split_fn, "split", true), 2, 3),
{ strnest_tc, sorp_tc, sorp_tc, split_tc },
nary_op(make_op(split_fn, "split", true), 3, 4))),
["string?"] = wrap(unary_pred(function (x)
return stype(x) == "string"
end, "string?")),
["symbol?"] = wrap(unary_pred(function (x)
return stype(x) == "symbol"
end, "symbol?")),
["to-entity"] = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
local s = ls[1]
if #s == 0 then return s end
return "&#" .. mw.ustring.codepoint(s, 1) .. ";"
end, "to-entity", true),
{ str_ls_tc }, function (ls)
ls = ls[1]
local r = { type = "list" }
for k = 1, #ls do
local s = ls[k]
if #s == 0 then r[k] = s
else r[k] = "&#" .. mw.ustring.codepoint(s, 1) .. ";"
end
end
return r
end), 1)),
["to-number"] = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
local n = tonumber(ls[1])
if n == nil then return { type="list" } else return n end
end, "to-number", true)), 1)),
["to-string"] = wrap(nary_op(typed_op(
{ "number" }, make_op(function (ls)
return write_sexpr(ls[1])
end, "to-string", true)),1)),
transformer = wrap(typed_op(
{ none_tc },
make_op(function (ls, env, depth)
return xformer_fn( 0, 0, 0, 0)
end, "transformer", true),
{ "fn", none_tc },
make_op(function (ls, env, depth)
return xformer_fn(ls[1], 0, 0, 0)
end, "transformer", true),
{ posint_tc, none_tc },
make_op(function (ls, env, depth)
return xformer_fn( 0, 0, 0, ls[1])
end, "transformer", true),
{ any_tc, "fn", none_tc },
nary_op(make_op(function (ls, env, depth)
return xformer_fn( 0, ls[1], ls[2], 0)
end, "transformer", true), -2),
{ "fn", posint_tc, none_tc },
make_op(function (ls, env, depth)
return xformer_fn(ls[1], 0, 0, ls[2])
end, "transformer", true),
{ "fn", any_tc, "fn", none_tc },
nary_op(make_op(function (ls, env, depth)
return xformer_fn(ls[1], ls[2], ls[3], 0)
end, "transformer", true), -3),
{ any_tc, "fn", posint_tc, none_tc },
make_op(function (ls, env, depth)
return xformer_fn( 0, ls[1], ls[2], ls[3])
end, "transformer", true),
{ "fn", any_tc, "fn", posint_tc, none_tc },
make_op(function (ls, env, depth)
return xformer_fn(ls[1], ls[2], ls[3], ls[4])
end, "transformer", true)
)),
trim = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
return mw.text.trim(ls[1])
end, "trim", true),
{ str_ls_tc }, function (ls)
ls = ls[1]
local r = { type = "list" }
for k = 1, #ls do r[k] = mw.text.trim(ls[k]) end
return r
end), 1)),
uc = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
return lang:uc(ls[1])
end, "uc", true),
{ str_ls_tc }, function (ls)
ls = ls[1]
local r = { type = "list" }
for k = 1, #ls do r[k] = lang:uc(ls[k]) end
return r
end), 1)),
ucfirst = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
return lang:ucfirst(ls[1])
end, "ucfirst", true),
{ str_ls_tc }, function (ls)
ls = ls[1]
local r = { type = "list" }
for k = 1, #ls do r[k] = lang:ucfirst(ls[k]) end
return r
end), 1)),
urlencode = wrap(nary_op(typed_op(
{ "string" }, make_op(function (ls)
if #ls == 1 then ls[2] = 'QUERY' end
return mw.uri.encode( ls[1], ls[2] )
end, "urlencode", true)), 1, 2)),
["wikilisp-version"] = wrap(nary_op(make_op(function (ls)
return wikilispversion
end, "wikilisp-version", true), 0)),
write = wrap(nary_op(make_op(function (ls)
return write_sexpr(ls[1])
end, "write", true), 1))
}
local function make_standard_env()
local standard_env = {}
setmetatable(standard_env, { __index = ground_env})
return standard_env
end
--[[ read-eval-print]]
function export.rep( frame )
local t = frame.args[1]
if t == nil then t = "" end
return display_sexpr(
eval_seq(
text_to_sexpr(t),
make_standard_env(),
maxdepth))
end
function export.trep( frame )
relevantFrame = frame:getParent()
return export.rep(frame)
end
return export