|
| 1 | +;;; a.el --- Associative data structure functions -*- lexical-binding: t; -*- |
| 2 | + |
| 3 | +;; Copyright (C) 2017 Arne Brasseur |
| 4 | + |
| 5 | +;; Author: Arne Brasseur <[email protected]> |
| 6 | +;; URL: https://github.com/plexus/a.el |
| 7 | +;; Package-Version: 20180907.953 |
| 8 | +;; Keywords: lisp |
| 9 | +;; Version: 0.1.1 |
| 10 | +;; Package-Requires: ((emacs "25")) |
| 11 | + |
| 12 | +;; This file is not part of GNU Emacs. |
| 13 | + |
| 14 | +;; This file 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, or (at your option) |
| 17 | +;; any later version. |
| 18 | + |
| 19 | +;; This file 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 GNU Emacs; see the file COPYING. If not, write to |
| 26 | +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 27 | +;; Boston, MA 02110-1301, USA. |
| 28 | + |
| 29 | +;;; Commentary: |
| 30 | + |
| 31 | +;; Library for dealing with associative data structures: alists, hash-maps, and |
| 32 | +;; vectors (for vectors, the indices are treated as keys). |
| 33 | +;; |
| 34 | +;; This library is largely inspired by Clojure, it has many of the functions |
| 35 | +;; found in clojure.core, prefixed with `a-'. All functions treat their |
| 36 | +;; arguments as immutable, so e.g. `a-assoc' will clone the hash-table or alist |
| 37 | +;; it is given. Keep this in mind when writing performance sensitive code. |
| 38 | + |
| 39 | +;;; Code: |
| 40 | + |
| 41 | +(eval-when-compile (require 'subr-x)) ;; for things like hash-table-keys |
| 42 | + |
| 43 | +(require 'cl-lib) |
| 44 | +(require 'seq) |
| 45 | + |
| 46 | +(defun a-associative-p (obj) |
| 47 | + (or (not obj) |
| 48 | + (hash-table-p obj) |
| 49 | + (and (consp obj) (consp (car obj))))) |
| 50 | + |
| 51 | +(defalias 'a-associative? 'a-associative-p) |
| 52 | + |
| 53 | +(defun a-get (map key &optional not-found) |
| 54 | + "Return the value MAP mapped to KEY, NOT-FOUND or nil if key not present." |
| 55 | + (cond |
| 56 | + ;; own implementation instead of alist-get so keys are checked with equal |
| 57 | + ;; instead of eq |
| 58 | + ((listp map) |
| 59 | + (a--alist-get map key not-found)) |
| 60 | + |
| 61 | + ((vectorp map) |
| 62 | + (if (a-has-key? map key) |
| 63 | + (aref map key) |
| 64 | + not-found)) |
| 65 | + |
| 66 | + ((hash-table-p map) |
| 67 | + (gethash key map not-found)) |
| 68 | + (t (user-error "Not associative: %S" map)))) |
| 69 | + |
| 70 | +(defun a--alist-get (map key &optional not-found) |
| 71 | + "Like alist-get, but uses equal instead of eq to look up in map MAP key KEY. |
| 72 | +Returns NOT-FOUND if the key is not present, or `nil' if |
| 73 | +NOT-FOUND is not specified." |
| 74 | + (cl-block nil |
| 75 | + (seq-doseq (pair map) |
| 76 | + (when (equal (car pair) key) |
| 77 | + (cl-return (cdr pair)))) |
| 78 | + not-found)) |
| 79 | + |
| 80 | +(defun a-get-in (m ks &optional not-found) |
| 81 | + "Look up a value in a nested associative structure. |
| 82 | +
|
| 83 | +Given a data structure M, and a sequence of keys KS, find the |
| 84 | +value found by using each key in turn to do a lookup in the next |
| 85 | +\"layer\". Return `nil' if the key is not present, or the NOT-FOUND |
| 86 | +value if supplied." |
| 87 | + (let ((result m)) |
| 88 | + (cl-block nil |
| 89 | + (seq-doseq (k ks) |
| 90 | + (if (a-has-key? result k) |
| 91 | + (setq result (a-get result k)) |
| 92 | + (cl-return not-found))) |
| 93 | + result))) |
| 94 | + |
| 95 | +(defmacro a-get* (&rest keys) |
| 96 | + "Look up a value in a nested associative structure. |
| 97 | +
|
| 98 | +Like a-get-in, but takes the key sequence KEYS directly as vararg |
| 99 | +arguments, rather than as a single sequence." |
| 100 | + (cl-labels ((rec (keys) |
| 101 | + `(a-get ,(if (and (consp (cdr keys)) |
| 102 | + (cddr keys)) |
| 103 | + (rec (cdr keys)) |
| 104 | + (cadr keys)) |
| 105 | + ,(car keys)))) |
| 106 | + (rec (nreverse keys)))) |
| 107 | + |
| 108 | +(defun a-has-key (coll k) |
| 109 | + "Check if the given associative collection COLL has a certain key K." |
| 110 | + (cond |
| 111 | + ((listp coll) (not (eq (a--alist-get coll k :not-found) :not-found))) |
| 112 | + ((vectorp coll) (and (integerp k) (< -1 k (length coll)))) |
| 113 | + ((hash-table-p coll) (not (eq (gethash k coll :not-found) :not-found))) |
| 114 | + (t (user-error "Not associative: %S" coll)))) |
| 115 | + |
| 116 | +(defalias 'a-has-key? 'a-has-key) |
| 117 | + |
| 118 | +(defun a-assoc-1 (coll k v) |
| 119 | + "Like `a-assoc', (in COLL assoc K with V) but only takes a single k-v pair. |
| 120 | +Internal helper function." |
| 121 | + (cond |
| 122 | + ((listp coll) |
| 123 | + (if (a-has-key? coll k) |
| 124 | + (mapcar (lambda (entry) |
| 125 | + (if (equal (car entry) k) |
| 126 | + (cons k v) |
| 127 | + entry)) |
| 128 | + coll) |
| 129 | + (cons (cons k v) coll))) |
| 130 | + |
| 131 | + ((vectorp coll) |
| 132 | + (if (and (integerp k) (> k 0)) |
| 133 | + (if (< k (length coll)) |
| 134 | + (let ((copy (copy-sequence coll))) |
| 135 | + (aset copy k v) |
| 136 | + copy) |
| 137 | + (vconcat coll (make-list (- k (length coll)) nil) (list v))))) |
| 138 | + |
| 139 | + ((hash-table-p coll) |
| 140 | + (let ((copy (copy-hash-table coll))) |
| 141 | + (puthash k v copy) |
| 142 | + copy)))) |
| 143 | + |
| 144 | +(defun a-assoc (coll &rest kvs) |
| 145 | + "Return an updated collection COLL, associating values with keys KVS." |
| 146 | + (when (not (cl-evenp (a-count kvs))) |
| 147 | + (user-error "a-assoc requires an even number of arguments!")) |
| 148 | + (seq-reduce (lambda (coll kv) |
| 149 | + (seq-let [k v] kv |
| 150 | + (a-assoc-1 coll k v))) |
| 151 | + (seq-partition kvs 2) |
| 152 | + coll)) |
| 153 | + |
| 154 | +(defun a-keys (coll) |
| 155 | + "Return the keys in the collection COLL." |
| 156 | + (cond |
| 157 | + ((listp coll) |
| 158 | + (mapcar #'car coll)) |
| 159 | + |
| 160 | + ((hash-table-p coll) |
| 161 | + (hash-table-keys coll)))) |
| 162 | + |
| 163 | +(defun a-vals (coll) |
| 164 | + "Return the values in the collection COLL." |
| 165 | + (cond |
| 166 | + ((listp coll) |
| 167 | + (mapcar #'cdr coll)) |
| 168 | + |
| 169 | + ((hash-table-p coll) |
| 170 | + (hash-table-values coll)))) |
| 171 | + |
| 172 | +(defun a-reduce-kv (fn from coll) |
| 173 | + "Reduce with FN starting from FROM the collection COLL. |
| 174 | +Reduce an associative collection COLL, starting with an initial |
| 175 | +value of FROM. The reducing function FN receives the intermediate |
| 176 | +value, key, and value." |
| 177 | + (seq-reduce (lambda (acc key) |
| 178 | + (funcall fn acc key (a-get coll key))) |
| 179 | + (a-keys coll) |
| 180 | + from)) |
| 181 | + |
| 182 | +(defun a-count (coll) |
| 183 | + "Count the number of key-value pairs in COLL. |
| 184 | +Like length, but can also return the length of hash tables." |
| 185 | + (cond |
| 186 | + ((seqp coll) |
| 187 | + (length coll)) |
| 188 | + |
| 189 | + ((hash-table-p coll) |
| 190 | + (hash-table-count coll)))) |
| 191 | + |
| 192 | +(defun a-equal (a b) |
| 193 | + "Compare collections A, B for value equality. |
| 194 | +
|
| 195 | +Associative collections (hash tables and a-lists) are considered |
| 196 | +equal if they contain equal key-value pairs, regardless of order. |
| 197 | +
|
| 198 | +Sequences (lists or vectors) are considered equal if they contain |
| 199 | +the same elements in the same order. |
| 200 | +
|
| 201 | +Collection elements are compared using `a-equal'. In other words, |
| 202 | +the equality check is recursive, resulting in a \"deep\" equality |
| 203 | +check. |
| 204 | +
|
| 205 | +Anything that isn't associative or a sequence is compared with |
| 206 | +`equal'." |
| 207 | + (cond |
| 208 | + ((and (a-associative? a) (a-associative? b)) |
| 209 | + (or (equal a b) |
| 210 | + (when (eq (a-count a) (a-count b)) |
| 211 | + (cl-block nil |
| 212 | + (seq-doseq (k (a-keys a)) |
| 213 | + (when (not (a-equal (a-get a k) (a-get b k))) |
| 214 | + (cl-return nil))) |
| 215 | + t)))) |
| 216 | + ((and (sequencep a) (sequencep b)) |
| 217 | + (and (eq (length a) (length b)) |
| 218 | + (or (and (seq-empty-p a) (seq-empty-p b)) |
| 219 | + (and (a-equal (elt a 0) (elt b 0)) |
| 220 | + (a-equal (seq-drop a 1) (seq-drop b 1)))))) |
| 221 | + (t |
| 222 | + (equal a b)))) |
| 223 | + |
| 224 | +(defalias 'a-equal? 'a-equal) |
| 225 | + |
| 226 | +(defun a-merge (&rest colls) |
| 227 | + "Merge multiple associative collections. |
| 228 | +Return the type of the first collection COLLS." |
| 229 | + (seq-reduce (lambda (this that) |
| 230 | + (a-reduce-kv (lambda (coll k v) |
| 231 | + (a-assoc coll k v)) |
| 232 | + this |
| 233 | + that)) |
| 234 | + (cdr colls) |
| 235 | + (car colls))) |
| 236 | + |
| 237 | +(defun a-merge-with (f &rest colls) |
| 238 | + "Merge multiple associative collections. |
| 239 | +Return the type of the first collection COLLS. If a key exists in |
| 240 | +both, then combine the associated values by calling f on them." |
| 241 | + (seq-reduce (lambda (this that) |
| 242 | + (a-reduce-kv (lambda (coll k v) |
| 243 | + (a-assoc coll k (if (a-has-key coll k) |
| 244 | + (funcall f v (a-get coll k)) |
| 245 | + v))) |
| 246 | + this |
| 247 | + that)) |
| 248 | + (cdr colls) |
| 249 | + (car colls))) |
| 250 | + |
| 251 | +(defun a-alist (&rest kvs) |
| 252 | + "Create an association list from the given keys and values KVS. |
| 253 | +Arguments are simply provided in sequence, rather than as lists or cons cells. |
| 254 | +For example: (a-alist :foo 123 :bar 456)" |
| 255 | + (mapcar (lambda (kv) (cons (car kv) (cadr kv))) (seq-partition kvs 2))) |
| 256 | + |
| 257 | +(defalias 'a-list 'a-alist) |
| 258 | + |
| 259 | +(defun a-hash-table (&rest kvs) |
| 260 | + "Create a hash table from the given keys and values KVS. |
| 261 | +Arguments are simply provided in sequence, rather than as lists |
| 262 | +or cons cells. As \"test\" for the hash table, equal is used. The |
| 263 | +hash table is created without extra storage space, so with a size |
| 264 | +equal to amount of key-value pairs, since it is assumed to be |
| 265 | +treated as immutable. |
| 266 | +For example: (a-hash-table :foo 123 :bar 456)" |
| 267 | + (let* ((kv-pairs (seq-partition kvs 2)) |
| 268 | + (hash-map (make-hash-table :test 'equal :size (length kv-pairs)))) |
| 269 | + (seq-do (lambda (pair) |
| 270 | + (puthash (car pair) (cadr pair) hash-map)) |
| 271 | + kv-pairs) |
| 272 | + hash-map)) |
| 273 | + |
| 274 | +(defun a-assoc-in (coll keys value) |
| 275 | + "In collection COLL, at location KEYS, associate value VALUE. |
| 276 | +Associates a value in a nested associative collection COLL, where |
| 277 | +KEYS is a sequence of keys and VALUE is the new value and returns |
| 278 | +a new nested structure. If any levels do not exist, association |
| 279 | +lists will be created." |
| 280 | + (cl-case (length keys) |
| 281 | + (0 coll) |
| 282 | + (1 (a-assoc-1 coll (elt keys 0) value)) |
| 283 | + (t (a-assoc-1 coll |
| 284 | + (elt keys 0) |
| 285 | + (a-assoc-in (a-get coll (elt keys 0)) |
| 286 | + (seq-drop keys 1) |
| 287 | + value))))) |
| 288 | + |
| 289 | +(defun a-dissoc--list (list keys) |
| 290 | + "Return updated LIST with KEYS removed. |
| 291 | +Internal helper. Use `a-dissoc' instead." |
| 292 | + (a-reduce-kv (lambda (res k v) |
| 293 | + (if (member k keys) |
| 294 | + res |
| 295 | + (cons (cons k v) res))) |
| 296 | + nil |
| 297 | + list)) |
| 298 | + |
| 299 | +(defun a-dissoc--hash-table (table keys) |
| 300 | + "Return updated TABLE with KEYS removed. |
| 301 | +Internal helper. Use `a-dissoc' instead." |
| 302 | + (let ((new-table (make-hash-table :size (hash-table-count table) |
| 303 | + :test (hash-table-test table))) |
| 304 | + (rest-keys (seq-remove (lambda (k) |
| 305 | + (member k keys)) |
| 306 | + (a-keys table)))) |
| 307 | + (seq-doseq (k rest-keys) |
| 308 | + (puthash k (gethash k table) new-table)) |
| 309 | + new-table)) |
| 310 | + |
| 311 | +(defun a-dissoc (coll &rest keys) |
| 312 | + "Return an updated version of collection COLL with the KEY removed." |
| 313 | + (cond |
| 314 | + ((listp coll) (a-dissoc--list coll keys)) |
| 315 | + ((hash-table-p coll) (a-dissoc--hash-table coll keys)))) |
| 316 | + |
| 317 | +(defun a-update (coll key fn &rest args) |
| 318 | + "In collection COLL, at location KEY, apply FN with extra args ARGS. |
| 319 | +'Updates' a value in an associative collection COLL, where KEY is |
| 320 | +a key and FN is a function that will take the old value and any |
| 321 | +supplied args and return the new value, and returns a new |
| 322 | +structure. If the key does not exist, nil is passed as the old |
| 323 | +value." |
| 324 | + (a-assoc-1 coll |
| 325 | + key |
| 326 | + (apply #'funcall fn (a-get coll key) args))) |
| 327 | + |
| 328 | +(defun a-update-in (coll keys fn &rest args) |
| 329 | + "In collection COLL, at location KEYS, apply FN with extra args ARGS. |
| 330 | +'Updates' a value in a nested associative collection COLL, where |
| 331 | +KEYS is a sequence of keys and FN is a function that will take |
| 332 | +the old value and any supplied ARGS and return the new value, and |
| 333 | +returns a new nested structure. If any levels do not exist, |
| 334 | +association lists will be created." |
| 335 | + (cl-case (length keys) |
| 336 | + (0 coll) |
| 337 | + (1 (apply #'a-update coll (elt keys 0) fn args)) |
| 338 | + (t (a-assoc-1 coll |
| 339 | + (elt keys 0) |
| 340 | + (apply #'a-update-in |
| 341 | + (a-get coll (elt keys 0)) |
| 342 | + (seq-drop keys 1) |
| 343 | + fn |
| 344 | + args))))) |
| 345 | + |
| 346 | +(provide 'a) |
| 347 | +;;; a.el ends here |
0 commit comments