Create a gist now

Instantly share code, notes, and snippets.

@Nymphium /README.md
Last active Feb 18, 2016

What would you like to do?
functional programming langageか?

untyped

$ rlwrap ./repl.moon
> p = \x \y \z + <x, +<y, z>>
> print (p 3 4 5)
12
> -- comment
>

builtin function

  • print any_type -> nil print arg to terminal
  • + pair -> number
  • - pair -> number
  • * pair -> number
  • / pair -> number
  • left pair -> any_type
  • right pair -> any_type
  • u pair -> [right pair]th number of [left pair] ex:

u <<0, <1, <2, <3, 4>>>>, 3> -- return 3 u <<<0, 1>, <2, 3>>, 0> -- return 0 u <<<0, 1>, <2, 3>>, 1> -- return 2 u <<<0, 1>, <2, 3>>, 2> -- return 3 ```

lambda

only arg, only return

  • \x x => function(x) return x end

type

  • number 1, -5, 0.8,...
  • pair < any_type, _any_type >
  • lambda
local remove
remove = table.remove
local insert
insert = function(t, i, o)
if not (o) then
o, i = i, #t + 1
end
table.insert(t, i, o)
return t
end
local inspect = require("inspect")
local t_str
t_str = function(obj)
return type(obj) == "string"
end
local t_tbl
t_tbl = function(obj)
return type(obj) == "table"
end
local noop
noop = function(x)
return x
end
local cp_tbl
cp_tbl = function(t)
local ret = { }
for i, j in pairs(t) do
if t_tbl(j) then
ret[i] = cp_tbl(j)
else
ret[i] = j
end
end
do
local _M = getmetatable(t)
if _M then
setmetatable(ret, _M)
end
end
return ret
end
local strmguard
strmguard = function(str, t)
for i = 1, #t, 2 do
if not (t_str(t[i]) or type(t[i + 1]) == "function") then
error("strmguard failed")
end
if str:match(t[i]) then
return t[i + 1]()
end
end
if t.default then
return t.default()
end
end
local funstack, builtin, eval_exp, eval_lambda, eval_apply, eval_block, eval
funstack = {
pushcresume = function(self, fun)
return coroutine.resume((insert(self, {
coroutine.create(fun)
}))[#self][1])
end,
stopregret = function(self, ret)
return coroutine.yield((insert(self[#self], ret))[#self][1])
end,
pop = function(self)
return remove(self)
end
}
builtin = {
["+"] = function(pair)
return pair[1] + pair[2]
end,
["-"] = function(pair)
return pair[1] - pair[2]
end,
["*"] = function(pair)
return pair[1] * pair[2]
end,
["/"] = function(pair)
return pair[1] / pair[2]
end,
left = function(pair)
return pair[1]
end,
right = function(pair)
return pair[2]
end,
print = function(a)
return (function(x)
return print(x)
end)((inspect(a)):gsub("{(.*)}", "<%1>"):gsub("function", "lambda"):gsub("nil", "undefined"))
end
}
eval_exp = function(exp, env, k)
local _exp_0 = type(exp)
if "string" == _exp_0 then
return k(strmguard(exp, {
"^%d",
function()
return tonumber(exp)
end,
"^%.%d",
function()
return tonumber(exp)
end,
"^[_a-zA-Z]",
function()
return env[exp]
end
}))
elseif "table" == _exp_0 then
local _exp_1 = exp.label
if "pair" == _exp_1 then
return eval_exp(exp[1], env, function(left)
return eval_exp(exp[2], env, function(right)
return k({
left,
right
})
end)
end)
elseif "apply" == _exp_1 then
return eval_apply(exp, env, function(exp)
return k(exp)
end)
elseif "lambda" == _exp_1 then
return eval_lambda(exp, env, k)
end
else
return exp
end
end
eval_lambda = function(lambda, env, k)
local nenv = cp_tbl(env)
return k(function(arg)
nenv[lambda[1]] = arg
funstack:pushcresume((function()
return eval(lambda[2], nenv)
end))
return funstack:pop()[2]
end)
end
eval_apply = function(line, env, k)
local fun = remove(line, 1)
if t_str(fun) then
fun = env[fun]
end
return eval_exp((remove(line, 1)), env, function(exp)
local _exp_0 = type(fun)
if "function" == _exp_0 then
return line[1] and (eval_apply((insert(line, 1, fun(exp))), env, k)) or (k(fun(exp)))
elseif "table" == _exp_0 then
local _exp_1 = fun.label
if "apply" == _exp_1 then
return eval_apply(fun, env, function(f)
return line[1] and (eval_apply((insert(line, 1, f)), env, k)) or (k(f(exp)))
end)
elseif "lambda" == _exp_1 then
return eval_lambda(fun, env, function(f)
return line[1] and (eval_apply((insert(line, 1, f)), env, k)) or (k(f(exp)))
end)
end
end
end)
end
eval_block = function(stat, env, k)
local _exp_0 = stat.label
if "var" == _exp_0 then
return k(eval_exp(stat[2], env, function(exp)
env[stat[1]] = exp
end))
elseif "apply" == _exp_0 then
return eval_apply(stat, env, k)
elseif "return" == _exp_0 then
return eval_exp(stat[1], env, function(exp)
return funstack:stopregret(exp)
end)
end
end
eval = function(syntaxtree, env, k)
if k == nil then
k = noop
end
syntaxtree = cp_tbl(syntaxtree)
if not (syntaxtree[1]) then
return k(env or { })
else
env = setmetatable((env or { }), {
__index = builtin
})
return eval_block((remove(syntaxtree, 1)), env, function()
return eval(syntaxtree, env, k)
end)
end
end
return eval
import remove from table
insert = (t, i, o) ->
unless o
o, i = i, #t + 1
table.insert t, i, o
t
inspect = require"inspect"
typeS = (obj) -> type(obj) == "string"
typeT = (obj) -> type(obj) == "table"
noop = (x) -> x
cp_tbl = (t) ->
ret = {}
for i, j in pairs t
if typeT j
ret[i] = cp_tbl j
else
ret[i] = j
if _M = getmetatable t
setmetatable ret, _M
ret
strmguard = (str, t) ->
for i = 1, #t, 2
unless typeS(t[i]) or type(t[i + 1]) == "function"
error "strmguard failed"
if str\match t[i]
return t[i + 1]!
t.default! if t.default
local *
funstack =
pushcresume: (fun) => coroutine.resume (insert @, {coroutine.create fun})[#@][1]
stopregret: (ret) => coroutine.yield (insert @[#@], ret)[#@][1]
pop: => remove @
builtin = {
["+"]: (pair) -> pair[1] + pair[2]
["-"]: (pair) -> pair[1] - pair[2]
["*"]: (pair) -> pair[1] * pair[2]
["/"]: (pair) -> pair[1] / pair[2]
left: (pair) -> pair[1]
right: (pair) -> pair[2]
u: (pair) ->
import left, right, u from builtin
t, cnt = left(pair), right(pair)
if cnt == 0
left t
typeT(left t) and (u {(left t), 0}) or left t
elseif cnt == 1
typeT(right t) and (u {(right t), 0}) or right t
else
u {right(t), cnt - 1}
print: (a) -> ((x) -> print x) (inspect a)\gsub("{", "<")\gsub("}", ">")\gsub("function", "lambda")\gsub("nil", "undefined")
}
eval_exp = (exp, env, k) -> switch type(exp)
when "string" k strmguard exp, {
"^%d", -> tonumber exp
"^%.%d", -> tonumber exp
"^[_a-zA-Z]", -> env[exp]
}
when "table" switch exp.label
when "pair"
eval_exp exp[1], env, (left) -> eval_exp exp[2], env, (right) -> k {left, right}
when "apply"
eval_apply exp, env, (exp) -> k exp
when "lambda"
eval_lambda exp, env, k
else
exp
eval_lambda = (lambda, env, k) ->
nenv = cp_tbl env
k (arg) ->
nenv[lambda[1]] = arg
funstack\pushcresume (-> eval lambda[2], nenv)
funstack\pop![2]
eval_apply = (line, env, k) ->
fun = remove line, 1
fun = env[fun] if typeS fun
eval_exp (remove line, 1), env, (exp) -> switch type fun
when "function" line[1] and (eval_apply (insert line, 1, fun exp), env, k) or (k fun exp)
when "table" switch fun.label
when "apply" eval_apply fun, env, (f) -> line[1] and (eval_apply (insert line,1, f), env, k) or (k f exp)
when "lambda" eval_lambda fun, env, (f) -> line[1] and (eval_apply (insert line, 1, f), env, k) or (k f exp)
eval_block = (stat, env, k) -> switch stat.label
when "var" k eval_exp stat[2], env, (exp) -> env[stat[1]] = exp
when "apply" eval_apply stat, env, k
when "return" eval_exp stat[1], env, (exp) -> funstack\stopregret exp
eval = (syntaxtree, env, k = noop) ->
syntaxtree = cp_tbl syntaxtree
unless syntaxtree[1]
k env or {}
else
env = setmetatable (env or {}), __index: builtin
eval_block (remove syntaxtree, 1), env, -> eval syntaxtree, env, k
eval
local P, S, V, C, Ct, locale, match
do
local _obj_0 = require('lpeg')
P, S, V, C, Ct, locale, match = _obj_0.P, _obj_0.S, _obj_0.V, _obj_0.C, _obj_0.Ct, _obj_0.locale, _obj_0.match
end
local insert, remove
do
local _obj_0 = table
insert, remove = _obj_0.insert, _obj_0.remove
end
local inspect = require("inspect")
local iprint
iprint = function(...)
return print((inspect({
...
})):match("^{ (.*) }$"))
end
locale = locale()
local CS
CS = function(pat)
return C(S(pat))
end
local CtV
CtV = function(pat)
return Ct(V(pat))
end
local opt
opt = function(pat)
return (pat) ^ -1
end
local ast
ast = function(pat)
return (pat) ^ 0
end
local Name = (locale.alpha + P('_')) * ast(locale.alnum + P('_'))
local Number = opt(P('-')) * locale.digit ^ 1
local Space = ast(locale.space)
local Brac
Brac = function(cont)
return P('(') * Space * cont * Space * P(')')
end
local lbl_tbl
lbl_tbl = function(lbl)
return function(...)
local args = {
...
}
if type(args[1]) == "string" and #args[1] < 1 then
return {
label = lbl
}
else
return {
label = lbl,
...
}
end
end
end
local left_join
left_join = function(...)
local t = {
...
}
local h = remove(t)
if #t > 0 then
insert(h, 1, left_join(unpack(t)))
end
return h
end
local untyped = P({
CtV('Block') * Space * -P(1),
Block = ast(Space * V('Stat')),
Stat = P('--') * ast(P(1) - P('\n')) * (P('\n') + -P(1)) + C(Name) * Space * P('=') * Space * (V('Apply') + V('Exp')) / lbl_tbl('var') + V('Apply'),
Pair = P('<') * Space * (V('Exp') + V('Apply')) * Space * (V('Apply') + V('Exp')) * Space * P('>') / lbl_tbl('pair'),
Lambda = P([[\]]) * Space * C(Name) * Space * Ct((V('Apply') + V('Exp')) / lbl_tbl('return')) / lbl_tbl('lambda'),
Apply = V('Fun') * (Space * (V('Fun') + V('Exp'))) ^ 1 / lbl_tbl('apply'),
Exp = C(Number) + P('<') * Space * (V('Apply') + V('Exp')) * Space * P(',') * Space * (V('Apply') + V('Exp')) * Space * P('>') / lbl_tbl('pair') + V('Lambda') + C(Name),
Fun = Brac(V('Lambda')) + C(Name) + CS('+*-/') + (Brac(V('Apply')))
})
return function(msg)
return untyped:match(msg)
end
import P, S, V, C, Ct, locale, match from require 'lpeg'
import insert, remove from table
inspect = require"inspect"
iprint = (...) -> print (inspect {...})\match("^{ (.*) }$")
locale = locale!
CS = (pat) -> C S pat
CtV = (pat) -> Ct V pat
opt = (pat) -> (pat)^-1
ast = (pat) -> (pat)^0
Name = (locale.alpha + P'_') * ast(locale.alnum + P'_')
Number = opt(P'-') * locale.digit^1
Space = ast(locale.space)
Brac = (cont) -> P'(' * Space * cont * Space * P')'
lbl_tbl = (lbl) -> (...) ->
args = {...}
if type(args[1]) == "string" and #args[1] < 1
label: lbl
else
{label: lbl, ...}
-- {f, g}, {h}, {i} ==> {{{f, g}, h}, i}
left_join = (...) ->
t = {...}
h = remove t
if #t > 0
insert h, 1, left_join unpack t
h
untyped = P {
CtV'Block' * Space * -P(1)
Block: ast(Space * V'Stat')
Stat:
V'Comment' +
V'Var' +
V'Apply'
Comment: P'--' * ast(P(1) - P'\n') * (P'\n' + -P(1))
Var: C(Name) * Space * P'=' * Space * (V'Apply' + V'Exp') / lbl_tbl'var'
Apply: V'Fun' * (Space * (V'Fun' + V'Exp'))^1 / lbl_tbl'apply'
Pair: P'<' * Space * (V'Exp' + V'Apply') * Space * P',' * Space * (V'Apply' + V'Exp') * Space * P'>' / lbl_tbl'pair'
Lambda: P[[\]] * Space * C(Name) * Space * Ct((V'Apply' + V'Exp') / lbl_tbl'return') / lbl_tbl'lambda'
Exp:
C(Number) +
V'Pair' +
-- P'<' * Space * (V'Apply' + V'Exp') * Space * P',' * Space * (V'Apply' + V'Exp') * Space * P'>' / lbl_tbl'pair' +
V'Lambda' +
C(Name)
Fun: Brac(V'Lambda') + C(Name) + CS'+*-/' + (Brac(V'Apply'))
}
(msg) -> untyped\match msg
local parse = require("parse")
local eval = require("eval")
local inspect = require('inspect')
local iprint
iprint = function(...)
return print((inspect({
...
})):match("^{ (.*) }$"))
end
local parseval
parseval = function(line, env)
local tree = parse(line)
if not tree then
local ok = pcall(eval, (parse("print " .. tostring(line))), env)
if not (ok) then
return print("failed to parse")
end
elseif #tree > 0 then
local ok, err = pcall(eval, tree, env)
if not (ok) then
return print(err)
end
end
end
local env = { }
local block = { }
local prompt = ">"
local continue_flag
while true do
local _continue_0 = false
repeat
io.write(tostring(prompt) .. " ")
local ok, line = pcall(io.read)
if not (ok and line) then
return
end
do
local line_withn = line:match('(.-)%s*\\%s*$')
if line_withn then
prompt = ">>"
table.insert(block, line_withn)
continue_flag = true
_continue_0 = true
break
elseif continue_flag then
table.insert(block, line)
prompt = ">"
end
end
continue_flag = false
if #block > 0 then
parseval((table.concat(block, '\n')), env)
block = { }
else
parseval(line, env)
end
_continue_0 = true
until true
if not _continue_0 then
break
end
end
#!/usr/bin/env moon
parse = require"parse"
eval = require"eval"
inspect = require'inspect'
iprint = (...) -> print (inspect {...})\match("^{ (.*) }$")
parseval = (line, env) ->
tree = parse line
if not tree
ok = pcall eval, (parse "print #{line}"), env
print "failed to parse" unless ok
elseif #tree > 0
ok, err = pcall eval, tree, env
print err unless ok
-- repl body
env = {}
block = {}
prompt = ">"
local continue_flag
while true
io.write"#{prompt} "
ok, line = pcall io.read
return unless ok and line
if line_withn = line\match'(.-)%s*\\%s*$'
prompt = ">>"
table.insert block, line_withn
continue_flag = true
continue
elseif continue_flag
table.insert block, line
prompt = ">"
continue_flag = false
if #block > 0
parseval (table.concat block, '\n'), env
block = {}
else
parseval line, env
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment