path: root/type.lua

--- lam.type
-- this library implements lam types---atomic and collection---and type
-- predicates.  it also re-exports lua's `type` as type.luatype and implements
-- `type.lamtype`.  types are implemented as functions to build the given type
-- from some arguments.  their metatables contain various metamethods, but also
-- `__type`.

local m = {}
local utf8 = require("utf8")
local util = require("util")
local tochars, error, constantly = util.tochars, util.error, util.constantly

---[[ ATOMIC TYPES ]]---

-- a lam symbol is a lua string
m.symbol = tostring

-- a lam number is a lua number
-- TODO: implement full numeric tower
m.number = tonumber

-- a character is a wrapped single-character string
-- it contains both the string representation and the character's codepoint

m.character_names = {
	-- some characters, like whitespace, have names
	["\n"] = "newline",
	[" "] = "space",
	["\t"] = "tab",
}

function m.character (x)
	local s = tostring(x)
	local uc = utf8.codepoint(s)
	local t = {
		v = utf8.char(uc),
		u = uc,
	}
	local mt = {
		__type = "char", -- scheme name
		-- compare using codepoints since they're just numbers
		__eq = function (a, b) return a.u == b.u end,
		__lt = function (a, b) return a.u < b.u end,
		__tostring =
			function (self)
				local v = self.v
				if m.character_names[v] then
					v = m.character_names[v]
				end
				return "#\\" .. v
			end,
	}
	return setmetatable(t, mt)
end

---[[ PROCEEDURES AND ENVIRONMENTS ]]---

function m.environment (inner, outer)
	local mt = {
		__type = "environment",
		__index = outer,
		__newindex =
			function (self, key, val)
				if rawget(self, key) then
					rawset(self, key, val)
				else
					getmetatable(self).__index[key] = val
				end
			end,
		__tostring = constantly("#<environment>"),
	}
	return setmetatable(inner, mt)
end

function m.procedure (params, body, env, eval)
	local t = {
		params = params,
		body = body,
		env = env,
		eval = eval,
	}
	local mt = {
		__type = "procedure",
		__tostring =
			function (self)
				return string.format("(lambda %s %s)",
					params,
					tostring(body):sub(2, -2))
			end,
		__call =
			function (self, r)
				local rlen = #r
				local function doargs (p, r, e)
					-- base case
					if m.nullp(p) and m.nullp(r) then
						return e
					end
					-- (lambda x ..) or (lambda (x . y) ..)
					if type.isp(p, "symbol") then
						e[p] = r
						return e
					end
					if p[1] == nil then
						error("too many arguments",
							rlen, #self.params)
					end
					if r[1] == nil then
						error("too few arguments",
							rlen, #self.params)
					end
					-- bind car(p) to car(r)
					e[p[1]] = r[1]
					-- recurse
					return doargs(p[2], r[2], e)
				end
				-- create new, expanded environment
				e = doargs(self.params, r,
					m.environment({}, self.env))
				local b = self.body
				-- evaluate body forms
				while not m.nullp(b[2]) do
					self.eval(b[1], e)
					b = b[2]
				end
				-- return last body form
				return self.eval(b[1], e)
			end,
	}
	return setmetatable(t, mt)
end

function m.assert_arity (r, min, max)
	local rmin = min or 0
	local rmax = max or 1/0 -- infinity
	local rlen = #r
	if rlen < rmin or rlen > rmax then
		error("wrong arity", rlen, m.cons(rmin, rmax))
	end
end

---[[ NULL ]]---
-- The empty list () is the only object that is both an atom and a list.  It
-- forms the ultimate tail of every "proper" list.  The important thing is that
-- it's its own object.

m.null = setmetatable({}, {
		__type = "null",
		__tostring = function () return "()" end,
})

function m.nullp (x)
	return x == m.null
end

---[[ COLLECTION TYPES ]]---

-- cons are lisp's fundamental collection type: they link two things together in
-- a structure
function m.cons (a, b)
	local t = { a, b, }
	local mt = {
		__type = "pair", -- scheme name
		__tostring =
			function (self)
				local t, p = {}, self
				while p[2] do
					table.insert(t, tostring(p[1]))
					if m.luatype(p[2]) == "table" then
						p = p[2]
					else
						table.insert(t, ".")
						table.insert(t, p[2])
						break
					end
				end
				return string.format("(%s)",
					table.concat(t, " "))
			end,
		__len =
			function (self)
				local function go (x, acc)
					-- improper lists don't have lengths
					if not m.isp(x, "pair") then
						return nil
					end
					if m.nullp(x[2]) then
						return acc
					else
						return go(x[2], acc + 1)
					end
				end
				return go(self, 1)
			end,
	}
	return setmetatable(t, mt)
end

-- a series of cons cells linked together is a list
function m.list (items, final)
	-- ITEMS is a table of items to turn into a list, and FINAL is an
	-- optional final cdr.  If it's nil, the list is a "proper" list,
	-- i.e. it ends in (); otherwise, it's an "improper" list.
	local function tolist (base, items)
		if #items == 0 then return base end
		return tolist(m.cons(table.remove(items), base), items)
	end
	return tolist(final or m.null, items)
end

-- strings are vectors of chars
function m.string (x)
	local t = tochars(tostring(x))
	local mt = {
		__type = "string",
		__tostring =
			function (self)
				local esc =
					table.concat(self):
					gsub("[\\\"]", "\\%1")
				return string.format("\"%s\"", esc)
			end,
	}
	return setmetatable(t, mt)
end

---[[ TYPE DETECTION AND PREDICATES ]]---

-- to avoid name clashes, `type` is saved in type.luatype
m.luatype = type

-- return the lam type of a given expression
function m.lamtype (x)
	if getmetatable(x) and getmetatable(x).__type then
		return getmetatable(x).__type
	elseif m.luatype(x) == "string" then
		return "symbol"
	else
		return m.luatype(x)
	end
end

--- Predicates are named with a `p', lisp-style

-- is X of type T ?
function m.isp (x, t)
	return m.lamtype(x) == t
end

-- is X a "proper" list?
function m.listp (x)
	-- take advantage of cons' __len operator, but since it returns a
	-- number, convert that to a bool
	if m.isp(x, "pair") and #x
	then return true
	else return false
	end
end

-- according to CHICKEN, `atom?' returns #t if X is not a pair (cons)
function m.atomp (x)
	return not m.isp(x, "pair")
end

--[[ CONVERTING BACK TO LUA TYPES ]]--

-- convert a cons back to a table
-- this doesn't special-case for proper/improper lists
function m.totable (cons)
	local t, p = {}, cons
	while p[2] do
		table.insert(t, p[1])
		if m.isp(p[2]) == "pair" then
			p = p[2]
		else
			table.insert(t, p[2])
		end
	end
	return t
end

--------
return m