Line data Source code
1 : ;;; map.el --- Map manipulation functions -*- lexical-binding: t; -*-
2 :
3 : ;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Nicolas Petton <nicolas@petton.fr>
6 : ;; Keywords: convenience, map, hash-table, alist, array
7 : ;; Version: 1.2
8 : ;; Package: map
9 :
10 : ;; Maintainer: emacs-devel@gnu.org
11 :
12 : ;; This file is part of GNU Emacs.
13 :
14 : ;; GNU Emacs is free software: you can redistribute it and/or modify
15 : ;; it under the terms of the GNU General Public License as published by
16 : ;; the Free Software Foundation, either version 3 of the License, or
17 : ;; (at your option) any later version.
18 :
19 : ;; GNU Emacs is distributed in the hope that it will be useful,
20 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 : ;; GNU General Public License for more details.
23 :
24 : ;; You should have received a copy of the GNU General Public License
25 : ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
26 :
27 : ;;; Commentary:
28 :
29 : ;; map.el provides map-manipulation functions that work on alists,
30 : ;; hash-table and arrays. All functions are prefixed with "map-".
31 : ;;
32 : ;; Functions taking a predicate or iterating over a map using a
33 : ;; function take the function as their first argument. All other
34 : ;; functions take the map as their first argument.
35 :
36 : ;; TODO:
37 : ;; - Add support for char-tables
38 : ;; - Maybe add support for gv?
39 : ;; - See if we can integrate text-properties
40 : ;; - A macro similar to let-alist but working on any type of map could
41 : ;; be really useful
42 :
43 : ;;; Code:
44 :
45 : (require 'seq)
46 : (eval-when-compile (require 'cl-lib))
47 :
48 : (pcase-defmacro map (&rest args)
49 : "Build a `pcase' pattern matching map elements.
50 :
51 : ARGS is a list of elements to be matched in the map.
52 :
53 : Each element of ARGS can be of the form (KEY PAT), in which case KEY is
54 : evaluated and searched for in the map. The match fails if for any KEY
55 : found in the map, the corresponding PAT doesn't match the value
56 : associated to the KEY.
57 :
58 : Each element can also be a SYMBOL, which is an abbreviation of a (KEY
59 : PAT) tuple of the form (\\='SYMBOL SYMBOL).
60 :
61 : Keys in ARGS not found in the map are ignored, and the match doesn't
62 : fail."
63 0 : `(and (pred mapp)
64 0 : ,@(map--make-pcase-bindings args)))
65 :
66 : (defmacro map-let (keys map &rest body)
67 : "Bind the variables in KEYS to the elements of MAP then evaluate BODY.
68 :
69 : KEYS can be a list of symbols, in which case each element will be
70 : bound to the looked up value in MAP.
71 :
72 : KEYS can also be a list of (KEY VARNAME) pairs, in which case
73 : KEY is an unquoted form.
74 :
75 : MAP can be a list, hash-table or array."
76 : (declare (indent 2) (debug t))
77 0 : `(pcase-let ((,(map--make-pcase-patterns keys) ,map))
78 0 : ,@body))
79 :
80 : (eval-when-compile
81 : (defmacro map--dispatch (map-var &rest args)
82 : "Evaluate one of the forms specified by ARGS based on the type of MAP-VAR.
83 :
84 : The following keyword types are meaningful: `:list',
85 : `:hash-table' and `:array'.
86 :
87 : An error is thrown if MAP-VAR is neither a list, hash-table nor array.
88 :
89 : Returns the result of evaluating the form associated with MAP-VAR's type."
90 : (declare (debug t) (indent 1))
91 : `(cond ((listp ,map-var) ,(plist-get args :list))
92 : ((hash-table-p ,map-var) ,(plist-get args :hash-table))
93 : ((arrayp ,map-var) ,(plist-get args :array))
94 : (t (error "Unsupported map: %s" ,map-var)))))
95 :
96 : (defun map-elt (map key &optional default testfn)
97 : "Lookup KEY in MAP and return its associated value.
98 : If KEY is not found, return DEFAULT which defaults to nil.
99 :
100 : If MAP is a list, `eql' is used to lookup KEY. Optional argument
101 : TESTFN, if non-nil, means use its function definition instead of
102 : `eql'.
103 :
104 : MAP can be a list, hash-table or array."
105 : (declare
106 : (gv-expander
107 : (lambda (do)
108 : (gv-letplace (mgetter msetter) `(gv-delay-error ,map)
109 : (macroexp-let2* nil
110 : ;; Eval them once and for all in the right order.
111 : ((key key) (default default) (testfn testfn))
112 : `(if (listp ,mgetter)
113 : ;; Special case the alist case, since it can't be handled by the
114 : ;; map--put function.
115 : ,(gv-get `(alist-get ,key (gv-synthetic-place
116 : ,mgetter ,msetter)
117 : ,default nil ,testfn)
118 : do)
119 : ,(funcall do `(map-elt ,mgetter ,key ,default)
120 : (lambda (v) `(map--put ,mgetter ,key ,v)))))))))
121 0 : (map--dispatch map
122 0 : :list (alist-get key map default nil testfn)
123 0 : :hash-table (gethash key map default)
124 0 : :array (if (and (>= key 0) (< key (seq-length map)))
125 0 : (seq-elt map key)
126 0 : default)))
127 :
128 : (defmacro map-put (map key value &optional testfn)
129 : "Associate KEY with VALUE in MAP and return VALUE.
130 : If KEY is already present in MAP, replace the associated value
131 : with VALUE.
132 : When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
133 :
134 : MAP can be a list, hash-table or array."
135 0 : `(setf (map-elt ,map ,key nil ,testfn) ,value))
136 :
137 : (defun map-delete (map key)
138 : "Delete KEY from MAP and return MAP.
139 : No error is signaled if KEY is not a key of MAP. If MAP is an
140 : array, store nil at the index KEY.
141 :
142 : MAP can be a list, hash-table or array."
143 0 : (map--dispatch map
144 0 : :list (setf (alist-get key map nil t) nil)
145 0 : :hash-table (remhash key map)
146 0 : :array (and (>= key 0)
147 0 : (<= key (seq-length map))
148 0 : (aset map key nil)))
149 0 : map)
150 :
151 : (defun map-nested-elt (map keys &optional default)
152 : "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil.
153 :
154 : Map can be a nested map composed of alists, hash-tables and arrays."
155 0 : (or (seq-reduce (lambda (acc key)
156 0 : (when (mapp acc)
157 0 : (map-elt acc key)))
158 0 : keys
159 0 : map)
160 0 : default))
161 :
162 : (defun map-keys (map)
163 : "Return the list of keys in MAP.
164 :
165 : MAP can be a list, hash-table or array."
166 0 : (map-apply (lambda (key _) key) map))
167 :
168 : (defun map-values (map)
169 : "Return the list of values in MAP.
170 :
171 : MAP can be a list, hash-table or array."
172 0 : (map-apply (lambda (_ value) value) map))
173 :
174 : (defun map-pairs (map)
175 : "Return the elements of MAP as key/value association lists.
176 :
177 : MAP can be a list, hash-table or array."
178 0 : (map-apply #'cons map))
179 :
180 : (defun map-length (map)
181 : "Return the length of MAP.
182 :
183 : MAP can be a list, hash-table or array."
184 0 : (length (map-keys map)))
185 :
186 : (defun map-copy (map)
187 : "Return a copy of MAP.
188 :
189 : MAP can be a list, hash-table or array."
190 0 : (map--dispatch map
191 0 : :list (seq-copy map)
192 0 : :hash-table (copy-hash-table map)
193 0 : :array (seq-copy map)))
194 :
195 : (defun map-apply (function map)
196 : "Apply FUNCTION to each element of MAP and return the result as a list.
197 : FUNCTION is called with two arguments, the key and the value.
198 :
199 : MAP can be a list, hash-table or array."
200 0 : (funcall (map--dispatch map
201 0 : :list #'map--apply-alist
202 0 : :hash-table #'map--apply-hash-table
203 0 : :array #'map--apply-array)
204 0 : function
205 0 : map))
206 :
207 : (defun map-do (function map)
208 : "Apply FUNCTION to each element of MAP and return nil.
209 : FUNCTION.is called with two arguments, the key and the value."
210 0 : (funcall (map--dispatch map
211 0 : :list #'map--do-alist
212 0 : :hash-table #'maphash
213 0 : :array #'map--do-array)
214 0 : function
215 0 : map))
216 :
217 : (defun map-keys-apply (function map)
218 : "Return the result of applying FUNCTION to each key of MAP.
219 :
220 : MAP can be a list, hash-table or array."
221 0 : (map-apply (lambda (key _)
222 0 : (funcall function key))
223 0 : map))
224 :
225 : (defun map-values-apply (function map)
226 : "Return the result of applying FUNCTION to each value of MAP.
227 :
228 : MAP can be a list, hash-table or array."
229 0 : (map-apply (lambda (_ val)
230 0 : (funcall function val))
231 0 : map))
232 :
233 : (defun map-filter (pred map)
234 : "Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP.
235 :
236 : MAP can be a list, hash-table or array."
237 0 : (delq nil (map-apply (lambda (key val)
238 0 : (if (funcall pred key val)
239 0 : (cons key val)
240 0 : nil))
241 0 : map)))
242 :
243 : (defun map-remove (pred map)
244 : "Return an alist of the key/val pairs for which (PRED key val) is nil in MAP.
245 :
246 : MAP can be a list, hash-table or array."
247 0 : (map-filter (lambda (key val) (not (funcall pred key val)))
248 0 : map))
249 :
250 : (defun mapp (map)
251 : "Return non-nil if MAP is a map (list, hash-table or array)."
252 0 : (or (listp map)
253 0 : (hash-table-p map)
254 0 : (arrayp map)))
255 :
256 : (defun map-empty-p (map)
257 : "Return non-nil if MAP is empty.
258 :
259 : MAP can be a list, hash-table or array."
260 0 : (map--dispatch map
261 0 : :list (null map)
262 0 : :array (seq-empty-p map)
263 0 : :hash-table (zerop (hash-table-count map))))
264 :
265 : (defun map-contains-key (map key &optional testfn)
266 : "If MAP contain KEY return KEY, nil otherwise.
267 : Equality is defined by TESTFN if non-nil or by `equal' if nil.
268 :
269 : MAP can be a list, hash-table or array."
270 0 : (seq-contains (map-keys map) key testfn))
271 :
272 : (defun map-some (pred map)
273 : "Return a non-nil if (PRED key val) is non-nil for any key/value pair in MAP.
274 :
275 : MAP can be a list, hash-table or array."
276 0 : (catch 'map--break
277 0 : (map-apply (lambda (key value)
278 0 : (let ((result (funcall pred key value)))
279 0 : (when result
280 0 : (throw 'map--break result))))
281 0 : map)
282 0 : nil))
283 :
284 : (defun map-every-p (pred map)
285 : "Return non-nil if (PRED key val) is non-nil for all elements of the map MAP.
286 :
287 : MAP can be a list, hash-table or array."
288 0 : (catch 'map--break
289 0 : (map-apply (lambda (key value)
290 0 : (or (funcall pred key value)
291 0 : (throw 'map--break nil)))
292 0 : map)
293 0 : t))
294 :
295 : (defun map-merge (type &rest maps)
296 : "Merge into a map of type TYPE all the key/value pairs in MAPS.
297 :
298 : MAP can be a list, hash-table or array."
299 0 : (let ((result (map-into (pop maps) type)))
300 0 : (while maps
301 : ;; FIXME: When `type' is `list', we get an O(N^2) behavior.
302 : ;; For small tables, this is fine, but for large tables, we
303 : ;; should probably use a hash-table internally which we convert
304 : ;; to an alist in the end.
305 0 : (map-apply (lambda (key value)
306 0 : (setf (map-elt result key) value))
307 0 : (pop maps)))
308 0 : result))
309 :
310 : (defun map-merge-with (type function &rest maps)
311 : "Merge into a map of type TYPE all the key/value pairs in MAPS.
312 : When two maps contain the same key, call FUNCTION on the two
313 : values and use the value returned by it.
314 : MAP can be a list, hash-table or array."
315 0 : (let ((result (map-into (pop maps) type))
316 0 : (not-found (cons nil nil)))
317 0 : (while maps
318 0 : (map-apply (lambda (key value)
319 0 : (cl-callf (lambda (old)
320 0 : (if (eq old not-found)
321 0 : value
322 0 : (funcall function old value)))
323 0 : (map-elt result key not-found)))
324 0 : (pop maps)))
325 0 : result))
326 :
327 : (defun map-into (map type)
328 : "Convert the map MAP into a map of type TYPE.
329 :
330 : TYPE can be one of the following symbols: list or hash-table.
331 : MAP can be a list, hash-table or array."
332 0 : (pcase type
333 0 : (`list (map-pairs map))
334 0 : (`hash-table (map--into-hash-table map))
335 0 : (_ (error "Not a map type name: %S" type))))
336 :
337 : (defun map--put (map key v)
338 0 : (map--dispatch map
339 0 : :list (let ((p (assoc key map)))
340 0 : (if p (setcdr p v)
341 0 : (error "No place to change the mapping for %S" key)))
342 0 : :hash-table (puthash key v map)
343 0 : :array (aset map key v)))
344 :
345 : (defun map--apply-alist (function map)
346 : "Private function used to apply FUNCTION over MAP, MAP being an alist."
347 0 : (seq-map (lambda (pair)
348 0 : (funcall function
349 0 : (car pair)
350 0 : (cdr pair)))
351 0 : map))
352 :
353 : (defun map--apply-hash-table (function map)
354 : "Private function used to apply FUNCTION over MAP, MAP being a hash-table."
355 0 : (let (result)
356 0 : (maphash (lambda (key value)
357 0 : (push (funcall function key value) result))
358 0 : map)
359 0 : (nreverse result)))
360 :
361 : (defun map--apply-array (function map)
362 : "Private function used to apply FUNCTION over MAP, MAP being an array."
363 0 : (let ((index 0))
364 0 : (seq-map (lambda (elt)
365 0 : (prog1
366 0 : (funcall function index elt)
367 0 : (setq index (1+ index))))
368 0 : map)))
369 :
370 : (defun map--do-alist (function alist)
371 : "Private function used to iterate over ALIST using FUNCTION."
372 0 : (seq-do (lambda (pair)
373 0 : (funcall function
374 0 : (car pair)
375 0 : (cdr pair)))
376 0 : alist))
377 :
378 : (defun map--do-array (function array)
379 : "Private function used to iterate over ARRAY using FUNCTION."
380 0 : (seq-do-indexed (lambda (elt index)
381 0 : (funcall function index elt))
382 0 : array))
383 :
384 : (defun map--into-hash-table (map)
385 : "Convert MAP into a hash-table."
386 0 : (let ((ht (make-hash-table :size (map-length map)
387 0 : :test 'equal)))
388 0 : (map-apply (lambda (key value)
389 0 : (setf (map-elt ht key) value))
390 0 : map)
391 0 : ht))
392 :
393 : (defun map--make-pcase-bindings (args)
394 : "Return a list of pcase bindings from ARGS to the elements of a map."
395 0 : (seq-map (lambda (elt)
396 0 : (if (consp elt)
397 0 : `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))
398 0 : `(app (pcase--flip map-elt ',elt) ,elt)))
399 0 : args))
400 :
401 : (defun map--make-pcase-patterns (args)
402 : "Return a list of `(map ...)' pcase patterns built from ARGS."
403 0 : (cons 'map
404 0 : (seq-map (lambda (elt)
405 0 : (if (and (consp elt) (eq 'map (car elt)))
406 0 : (map--make-pcase-patterns elt)
407 0 : elt))
408 0 : args)))
409 :
410 : (provide 'map)
411 : ;;; map.el ends here
|