diff options
Diffstat (limited to 'type.lua')
-rw-r--r-- | type.lua | 291 |
1 files changed, 192 insertions, 99 deletions
diff --git a/type.lua b/type.lua index f119270..c205468 100644 --- a/type.lua +++ b/type.lua | |||
@@ -1,112 +1,192 @@ | |||
1 | --- lam.type | 1 | --- lam.type |
2 | -- this library implements lam types---atomic and collection---and type | ||
3 | -- predicates. it also re-exports lua's `type` as type.luatype and implements | ||
4 | -- `type.lamtype`. types are implemented as functions to build the given type | ||
5 | -- from some arguments. their metatables contain various metamethods, but also | ||
6 | -- `__type`. | ||
2 | 7 | ||
3 | local m = {} | 8 | local m = {} |
4 | local utf8 = require "utf8" | 9 | local utf8 = require("utf8") |
5 | utf_char, utf_codepoint = utf8.char, utf8.codepoint | 10 | local util = require("util") |
11 | local tochars, error, constantly = util.tochars, util.error, util.constantly | ||
6 | 12 | ||
7 | --- atomic types | 13 | ---[[ ATOMIC TYPES ]]--- |
8 | 14 | ||
9 | -- true, false and nil are just ... true, false, and nil | 15 | -- a lam symbol is a lua string |
16 | m.symbol = tostring | ||
17 | |||
18 | -- a lam number is a lua number | ||
19 | -- TODO: implement full numeric tower | ||
20 | m.number = tonumber | ||
21 | |||
22 | -- a character is a wrapped single-character string | ||
23 | -- it contains both the string representation and the character's codepoint | ||
24 | |||
25 | m.character_names = { | ||
26 | -- some characters, like whitespace, have names | ||
27 | ["\n"] = "newline", | ||
28 | [" "] = "space", | ||
29 | ["\t"] = "tab", | ||
30 | } | ||
10 | 31 | ||
11 | -- Characters contain both their string reputations and their codepoints | ||
12 | function m.character (x) | 32 | function m.character (x) |
13 | -- is storing a character with its string and numerical representation | ||
14 | -- overkill? ... maybe. | ||
15 | local s = tostring(x) | 33 | local s = tostring(x) |
16 | local uc = utf_codepoint(s) | 34 | local uc = utf8.codepoint(s) |
17 | local t = { -- String representation of the character | 35 | local t = { |
18 | v = utf_char(uc), | 36 | v = utf8.char(uc), |
19 | u = uc, | 37 | u = uc, |
20 | } | 38 | } |
21 | local mt = { | 39 | local mt = { |
22 | __type = "character", | 40 | __type = "char", -- scheme name |
23 | __eq = function (self) return self.v end, | 41 | -- compare using codepoints since they're just numbers |
42 | __eq = function (a, b) return a.u == b.u end, | ||
24 | __lt = function (a, b) return a.u < b.u end, | 43 | __lt = function (a, b) return a.u < b.u end, |
25 | __tostring = | 44 | __tostring = |
26 | function (self) | 45 | function (self) |
27 | local v = self.v | 46 | local v = self.v |
28 | if v == "\n" then | 47 | if m.character_names[v] then |
29 | return "#\\newline" | 48 | v = m.character_names[v] |
30 | elseif v == " " then | ||
31 | return "#\\space" | ||
32 | else | ||
33 | return "#\\" .. v | ||
34 | end | 49 | end |
50 | return "#\\" .. v | ||
35 | end, | 51 | end, |
36 | } | 52 | } |
37 | return setmetatable(t, mt) | 53 | return setmetatable(t, mt) |
38 | end | 54 | end |
39 | 55 | ||
40 | -- a symbol is just a string, unadorned. I was going to have a character be | 56 | ---[[ PROCEEDURES AND ENVIRONMENTS ]]--- |
41 | -- represented by a one-character string, but then it would be indistinguishable | ||
42 | -- from a one-character symbol internally. | ||
43 | m.symbol = tostring | ||
44 | 57 | ||
45 | -- for now, number will just be lua's number. At *some* point, it will be the | 58 | function m.environment (inner, outer) |
46 | -- whole numeric tower, yaaayyy | 59 | local mt = { |
47 | m.number = tonumber | 60 | __type = "environment", |
61 | __index = outer, | ||
62 | __newindex = | ||
63 | function (self, key, val) | ||
64 | if rawget(self, key) then | ||
65 | rawset(self, key, val) | ||
66 | else | ||
67 | getmetatable(self).__index[key] = val | ||
68 | end | ||
69 | end, | ||
70 | __tostring = constantly("#<environment>"), | ||
71 | } | ||
72 | return setmetatable(inner, mt) | ||
73 | end | ||
48 | 74 | ||
49 | -- strings are wrapped strings | 75 | function m.procedure (params, body, env, eval) |
50 | function m.string (x) | ||
51 | local x = tostring(x) | ||
52 | local t = { | 76 | local t = { |
53 | v = x, | 77 | params = params, |
54 | escape = | 78 | body = body, |
55 | function (self) | 79 | env = env, |
56 | return self.v:gsub("[\\\"]", "\\%1") | 80 | eval = eval, |
57 | end, | ||
58 | } | 81 | } |
59 | local mt = { | 82 | local mt = { |
60 | __type = "string", | 83 | __type = "procedure", |
61 | __tostring = | 84 | __tostring = |
62 | function (self) | 85 | function (self) |
63 | return "\"" .. self:escape() .. "\"" | 86 | return string.format("(lambda %s %s)", |
87 | params, | ||
88 | tostring(body):sub(2, -2)) | ||
89 | end, | ||
90 | __call = | ||
91 | function (self, r) | ||
92 | local rlen = #r | ||
93 | local function doargs (p, r, e) | ||
94 | -- base case | ||
95 | if m.nullp(p) and m.nullp(r) then | ||
96 | return e | ||
97 | end | ||
98 | -- (lambda x ..) or (lambda (x . y) ..) | ||
99 | if type.isp(p, "symbol") then | ||
100 | e[p] = r | ||
101 | return e | ||
102 | end | ||
103 | if p[1] == nil then | ||
104 | error("too many arguments", | ||
105 | rlen, #self.params) | ||
106 | end | ||
107 | if r[1] == nil then | ||
108 | error("too few arguments", | ||
109 | rlen, #self.params) | ||
110 | end | ||
111 | -- bind car(p) to car(r) | ||
112 | e[p[1]] = r[1] | ||
113 | -- recurse | ||
114 | return doargs(p[2], r[2], e) | ||
115 | end | ||
116 | -- create new, expanded environment | ||
117 | e = doargs(self.params, r, | ||
118 | m.environment({}, self.env)) | ||
119 | local b = self.body | ||
120 | -- evaluate body forms | ||
121 | while not m.nullp(b[2]) do | ||
122 | self.eval(b[1], e) | ||
123 | b = b[2] | ||
124 | end | ||
125 | -- return last body form | ||
126 | return self.eval(b[1], e) | ||
64 | end, | 127 | end, |
65 | } | 128 | } |
66 | return setmetatable(t, mt) | 129 | return setmetatable(t, mt) |
67 | end | 130 | end |
68 | 131 | ||
69 | -- null () is both an atom and a list (yay) | 132 | function m.assert_arity (r, min, max) |
70 | -- this one is NOT a function | 133 | local rmin = min or 0 |
134 | local rmax = max or 1/0 -- infinity | ||
135 | local rlen = #r | ||
136 | if rlen < rmin or rlen > rmax then | ||
137 | error("wrong arity", rlen, m.cons(rmin, rmax)) | ||
138 | end | ||
139 | end | ||
140 | |||
141 | ---[[ NULL ]]--- | ||
142 | -- The empty list () is the only object that is both an atom and a list. It | ||
143 | -- forms the ultimate tail of every "proper" list. The important thing is that | ||
144 | -- it's its own object. | ||
145 | |||
71 | m.null = setmetatable({}, { | 146 | m.null = setmetatable({}, { |
72 | __type = "null", | 147 | __type = "null", |
73 | __tostring = function (self) return "()" end, | 148 | __tostring = function () return "()" end, |
74 | }) | 149 | }) |
75 | 150 | ||
76 | --- collection types | 151 | function m.nullp (x) |
152 | return x == m.null | ||
153 | end | ||
154 | |||
155 | ---[[ COLLECTION TYPES ]]--- | ||
77 | 156 | ||
78 | -- cons are lisp's fundamental collection type | 157 | -- cons are lisp's fundamental collection type: they link two things together in |
158 | -- a structure | ||
79 | function m.cons (a, b) | 159 | function m.cons (a, b) |
80 | local t = { a, b, } | 160 | local t = { a, b, } |
81 | local mt = { | 161 | local mt = { |
82 | __type = "cons", | 162 | __type = "pair", -- scheme name |
83 | __tostring = | 163 | __tostring = |
84 | function (self) | 164 | function (self) |
85 | local out = {} | 165 | local t, p = {}, self |
86 | local car, cdr = self[1], self[2] | 166 | while p[2] do |
87 | while cdr do | 167 | table.insert(t, tostring(p[1])) |
88 | table.insert(out, tostring(car)) | 168 | if m.luatype(p[2]) == "table" then |
89 | if m.luatype(cdr) == "table" then | 169 | p = p[2] |
90 | car = cdr[1] | ||
91 | cdr = cdr[2] | ||
92 | else | 170 | else |
93 | table.insert(out, ".") | 171 | table.insert(t, ".") |
94 | table.insert(out, cdr) | 172 | table.insert(t, p[2]) |
95 | break | 173 | break |
96 | end | 174 | end |
97 | end | 175 | end |
98 | return "(" .. table.concat(out, " ") .. ")" | 176 | return string.format("(%s)", |
177 | table.concat(t, " ")) | ||
99 | end, | 178 | end, |
100 | __len = | 179 | __len = |
101 | function (self) | 180 | function (self) |
102 | local function go (lis, acc) | 181 | local function go (x, acc) |
103 | -- improper lists don't have lengths | 182 | -- improper lists don't have lengths |
104 | -- ... but don't error here. | 183 | if not m.isp(x, "pair") then |
105 | if not m.isa(lis, "cons") then | ||
106 | return nil | 184 | return nil |
107 | end | 185 | end |
108 | if lis[2] == m.null then return acc | 186 | if m.nullp(x[2]) then |
109 | else return go(lis[2], acc+1) | 187 | return acc |
188 | else | ||
189 | return go(x[2], acc + 1) | ||
110 | end | 190 | end |
111 | end | 191 | end |
112 | return go(self, 1) | 192 | return go(self, 1) |
@@ -115,74 +195,87 @@ function m.cons (a, b) | |||
115 | return setmetatable(t, mt) | 195 | return setmetatable(t, mt) |
116 | end | 196 | end |
117 | 197 | ||
118 | -- lists are singly-linked cons cells | 198 | -- a series of cons cells linked together is a list |
119 | function m.list (items, last) | 199 | function m.list (items, final) |
120 | -- ITEMS is a table and LAST is an optional final cdr. If it's nil, the | 200 | -- ITEMS is a table of items to turn into a list, and FINAL is an |
121 | -- list is a "proper" list; that is, it ends in (). | 201 | -- optional final cdr. If it's nil, the list is a "proper" list, |
202 | -- i.e. it ends in (); otherwise, it's an "improper" list. | ||
122 | local function tolist (base, items) | 203 | local function tolist (base, items) |
123 | if #items == 0 then return base end | 204 | if #items == 0 then return base end |
124 | return tolist(m.cons(table.remove(items), base), items) | 205 | return tolist(m.cons(table.remove(items), base), items) |
125 | end | 206 | end |
126 | return tolist(last or m.null, items) | 207 | return tolist(final or m.null, items) |
127 | end | 208 | end |
128 | 209 | ||
129 | -- convert a list to a lua table | 210 | -- strings are vectors of chars |
130 | function m.totable (cons) | 211 | function m.string (x) |
131 | local t = {} | 212 | local t = tochars(tostring(x)) |
132 | local car, cdr = cons[1], cons[2] | 213 | local mt = { |
133 | while cdr do | 214 | __type = "string", |
134 | table.insert(t, car) | 215 | __tostring = |
135 | if m.luatype(cdr) == "table" then | 216 | function (self) |
136 | car = cdr[1] | 217 | local esc = |
137 | cdr = cdr[2] | 218 | table.concat(self): |
138 | else | 219 | gsub("[\\\"]", "\\%1") |
139 | table.insert(t, cdr) | 220 | return string.format("\"%s\"", esc) |
140 | end | 221 | end, |
141 | end | 222 | } |
142 | return t | 223 | return setmetatable(t, mt) |
143 | end | 224 | end |
144 | 225 | ||
145 | -- testing types | 226 | ---[[ TYPE DETECTION AND PREDICATES ]]--- |
146 | 227 | ||
147 | -- we love name collisions | 228 | -- to avoid name clashes, `type` is saved in type.luatype |
148 | m.luatype = type | 229 | m.luatype = type |
149 | 230 | ||
231 | -- return the lam type of a given expression | ||
150 | function m.lamtype (x) | 232 | function m.lamtype (x) |
151 | if m.luatype(x) == "string" then | 233 | if getmetatable(x) and getmetatable(x).__type then |
152 | return "symbol" | ||
153 | elseif getmetatable(x) and getmetatable(x).__type then | ||
154 | return getmetatable(x).__type | 234 | return getmetatable(x).__type |
235 | elseif m.luatype(x) == "string" then | ||
236 | return "symbol" | ||
155 | else | 237 | else |
156 | return m.luatype(x) | 238 | return m.luatype(x) |
157 | end | 239 | end |
158 | end | 240 | end |
159 | 241 | ||
160 | function m.isa (x, t) | 242 | --- Predicates are named with a `p', lisp-style |
243 | |||
244 | -- is X of type T ? | ||
245 | function m.isp (x, t) | ||
161 | return m.lamtype(x) == t | 246 | return m.lamtype(x) == t |
162 | end | 247 | end |
163 | 248 | ||
164 | function m.islist (x) | 249 | -- is X a "proper" list? |
165 | -- TODO: detect circular lists | 250 | function m.listp (x) |
166 | if x == m.null then | 251 | -- take advantage of cons' __len operator, but since it returns a |
167 | return true | 252 | -- number, convert that to a bool |
168 | elseif m.isa(x, "cons") then | 253 | if m.isp(x, "pair") and #x |
169 | return m.islist(x[2]) | 254 | then return true |
170 | else | 255 | else return false |
171 | return false | ||
172 | end | 256 | end |
173 | end | 257 | end |
174 | 258 | ||
175 | function m.isatom (x) | 259 | -- according to CHICKEN, `atom?' returns #t if X is not a pair (cons) |
176 | if x == m.null then | 260 | function m.atomp (x) |
177 | return true -- '() is the only value that is both atom and list | 261 | return not m.isp(x, "pair") |
178 | elseif m.luatype(x) == "table" then | 262 | end |
179 | -- generally, anything that's implemented as a table is *not* an | 263 | |
180 | -- atom, at least as I will define it. (it's not an actual | 264 | --[[ CONVERTING BACK TO LUA TYPES ]]-- |
181 | -- scheme procedure) | 265 | |
182 | return false | 266 | -- convert a cons back to a table |
183 | else | 267 | -- this doesn't special-case for proper/improper lists |
184 | return true | 268 | function m.totable (cons) |
269 | local t, p = {}, cons | ||
270 | while p[2] do | ||
271 | table.insert(t, p[1]) | ||
272 | if m.isp(p[2]) == "pair" then | ||
273 | p = p[2] | ||
274 | else | ||
275 | table.insert(t, p[2]) | ||
276 | end | ||
185 | end | 277 | end |
278 | return t | ||
186 | end | 279 | end |
187 | 280 | ||
188 | -------- | 281 | -------- |