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 utf8_char, utf8_codepoint, utf8_codes =
	utf8.char, utf8.codepoint, utf8.codes
local error = require("util").error

---[[ 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 char, code
	if m.luatype(x) == "number" then
		code = x
		char = utf8_char(x)
	elseif m.luatype(x) == "string" then
		code = utf8_codepoint(x)
		char = utf8_char(code)
	end
	local t = {
		char = char,
		code = code,
	}
	local mt = {
		__type = "char", -- scheme name
		-- compare using codepoints since they're just numbers
		__eq = function (a, b) return a.code == b.code end,
		-- comparing codepoints is probably not the *best* idea
		__lt = function (a, b) return a.code < b.code end,
		__tostring =
			function (self)
				local v = self.char
				if m.character_names[v] then
					v = m.character_names[v]
				end
				return "#\\" .. v
			end,
	}
	return setmetatable(t, mt)
end

---[[ INPUT PORTS ]]---

local function tochars (str)
	local cs = {}
	for _, code in utf8_codes(str) do
		table.insert(cs, code)
	end
	return cs
end

-- return the next token from PORT, given READTABLE
local function input_port_next_token (port, readtable)
	repeat
		if #port.buffer == 0 then
			if port.file then
				local ln = port.file:read()
				if ln == nil then
					return m.eof
				end
				port.buffer = tochars(ln)
			else
				return m.eof
			end
		end

		local token, token_type
		local c = port.buffer[1]
		if not c then return nil end
		if readtable.chars[c] then
			token, token_type, port.buffer =
				readtable.chars[c](port.buffer)
		else
			for re, fn in pairs(readtable.regex) do
				if c:match(re) then
					token, token_type, port.buffer =
						fn(port.buffer)
					break
				end
			end
			if token == nil then
				token, token_type, port.buffer =
					readtable.default(port.buffer)
			end
		end

		port.buffer = port.buffer or {}
		if token then
			return token, token_type
		end
	until nil
end

function m.input_port (source, source_type)
	-- SOURCE is the name of the file/string to read or nil; nil means
	-- standard input.  SOURCE_TYPE is one of "file", "string"; "file" is
	-- the default.
	local f, b
	source_type = source_type or "file"
	if source then
		if source_type == "file" then
			f = io.open(source, "r")
		elseif source_type == "string" then
			b = tochars(source)
		else
			error("input-port: bad type", source_type)
		end
	else
		f = io.input() -- ignore SOURCE_TYPE
	end
	local t = {
		file = f,
		name = f and source or "[string]",
		type = source_type,
		buffer = b or {},
		flush = function (self) self.buffer = {} end,
		next = input_port_next_token, -- port:next(readtable)
		close =
			function (self)
				if self.file then self.file:close() end
			end,
	}
	local mt = {
		__type = "input-port",
		__tostring =
			function (self)
				return string.format("#<port %s>", self.name)
			end,
	}
	return setmetatable(t, mt)
end

---[[ NULL(S) ]]---
-- 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

-- The EOF object is what the reader emits when it hits an end-of-file or use up
-- a port.
m.eof = setmetatable({}, {
		__type = "eof",
		__tostring = function () return "#<eof>" end,
})

function m.eofp (x)
	return x == m.eof
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.  not lam characters, but one-character strings.
-- this is for utf8 ease-of-use... TODO i still need to write functions to pluck
-- out a single lam character from a string, etc.
function m.string (x)
	local t
	if m.luatype(x) == "table" then
		t = x
	else
		t = tochars(tostring(x))
	end
	t.v = table.concat(t)
	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

---[[ 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 = function (_) return "#<environment>" end,
	}
	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("#<procedure %s>",
					self.params)
			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
						return rawset(e, p, r)
					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)
					rawset(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

---[[ 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

-- type assertion
function m.assert_type (x, t)
	local pred = function (a) return m.isp(a, t) end
	if t == "list" then pred = m.listp end
	if not pred(x) then
		error("wrong type", m.lamtype(x), t)
	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])
			break
		end
	end
	return t
end

--------
return m