code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/map.el

   1 ;;; map.el --- Map manipulation functions  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Nicolas Petton <nicolas@petton.fr>
   6 ;; Keywords: convenience, map, hash-table, alist, array
   7 ;; Version: 1.0
   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
  47 (pcase-defmacro map (&rest args)
  48   "pcase pattern matching map elements.
  49 Matches if the object is a map (list, hash-table or array), and
  50 binds values from ARGS to the corresponding element of the map.
  51
  52 ARGS can be a list elements of the form (KEY . PAT) or elements
  53 of the form SYMBOL, which stands for (SYMBOL . SYMBOL)."
  54   `(and (pred map-p)
  55         ,@(map--make-pcase-bindings args)))
  56
  57 (defmacro map-let (args map &rest body)
  58   "Bind the variables in ARGS to the elements of MAP then evaluate BODY.
  59
  60 ARGS can be an alist of key/binding pairs or a list of keys.  MAP
  61 can be a list, hash-table or array."
  62   (declare (indent 2) (debug t))
  63   `(pcase-let ((,(map--make-pcase-patterns args) ,map))
  64      ,@body))
  65
  66 (defmacro map--dispatch (spec &rest args)
  67   "Evaluate one of the forms specified by ARGS based on the type of MAP.
  68
  69 SPEC can be a map or a list of the form (VAR MAP [RESULT]).
  70 ARGS should have the form [TYPE FORM]...
  71
  72 The following keyword types are meaningful: `:list',
  73 `:hash-table' and `:array'.
  74
  75 An error is thrown if MAP is neither a list, hash-table nor array.
  76
  77 Return RESULT if non-nil or the result of evaluation of the
  78 form.
  79
  80 \(fn (VAR MAP [RESULT]) &rest ARGS)"
  81   (declare (debug t) (indent 1))
  82   (unless (listp spec)
  83     (setq spec `(,spec ,spec)))
  84   (let ((map-var (car spec))
  85         (result-var (make-symbol "result")))
  86     `(let ((,map-var ,(cadr spec))
  87            ,result-var)
  88        (setq ,result-var
  89              (cond ((listp ,map-var) ,(plist-get args :list))
  90                    ((hash-table-p ,map-var) ,(plist-get args :hash-table))
  91                    ((arrayp ,map-var) ,(plist-get args :array))
  92                    (t (error "Unsupported map: %s" ,map-var))))
  93        ,@(when (cddr spec)
  94            `((setq ,result-var ,@(cddr spec))))
  95        ,result-var)))
  96
  97 (defun map-elt (map key &optional default)
  98   "Perform a lookup in MAP of KEY and return its associated value.
  99 If KEY is not found, return DEFAULT which defaults to nil.
 100
 101 If MAP is a list, `equal' is used to lookup KEY.
 102
 103 MAP can be a list, hash-table or array."
 104   (map--dispatch map
 105     :list (map--elt-list map key default)
 106     :hash-table (gethash key map default)
 107     :array (map--elt-array map key default)))
 108
 109 (defmacro map-put (map key value)
 110   "In MAP, associate KEY with VALUE and return MAP.
 111 If KEY is already present in MAP, replace the associated value
 112 with VALUE.
 113
 114 MAP can be a list, hash-table or array."
 115   (declare (debug t))
 116   (let ((symbol (symbolp map)))
 117     `(progn
 118        (map--dispatch (m ,map m)
 119          :list (if ,symbol
 120                    (setq ,map (cons (cons ,key ,value) m))
 121                  (error "Literal lists are not allowed, %s must be a symbol" ',map))
 122          :hash-table (puthash ,key ,value m)
 123          :array (aset m ,key ,value)))))
 124
 125 (defmacro map-delete (map key)
 126   "In MAP, delete the key KEY if present and return MAP.
 127 If MAP is an array, store nil at the index KEY.
 128
 129 MAP can be a list, hash-table or array."
 130   (declare (debug t))
 131   (let ((symbol (symbolp map)))
 132     `(progn
 133        (map--dispatch (m ,map m)
 134          :list (if ,symbol
 135                    (setq ,map (map--delete-alist m ,key))
 136                  (error "Literal lists are not allowed, %s must be a symbol" ',map))
 137          :hash-table (remhash ,key m)
 138          :array (map--delete-array m ,key)))))
 139
 140 (defun map-nested-elt (map keys &optional default)
 141   "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil.
 142
 143 Map can be a nested map composed of alists, hash-tables and arrays."
 144   (or (seq-reduce (lambda (acc key)
 145                     (when (map-p acc)
 146                       (map-elt acc key)))
 147                   keys
 148                   map)
 149       default))
 150
 151 (defun map-keys (map)
 152   "Return the list of keys in MAP.
 153
 154 MAP can be a list, hash-table or array."
 155   (map-apply (lambda (key _) key) map))
 156
 157 (defun map-values (map)
 158   "Return the list of values in MAP.
 159
 160 MAP can be a list, hash-table or array."
 161   (map-apply (lambda (_ value) value) map))
 162
 163 (defun map-pairs (map)
 164   "Return the elements of MAP as key/value association lists.
 165
 166 MAP can be a list, hash-table or array."
 167   (map-apply #'cons map))
 168
 169 (defun map-length (map)
 170   "Return the length of MAP.
 171
 172 MAP can be a list, hash-table or array."
 173   (length (map-keys map)))
 174
 175 (defun map-copy (map)
 176   "Return a copy of MAP.
 177
 178 MAP can be a list, hash-table or array."
 179   (map--dispatch map
 180     :list (seq-copy map)
 181     :hash-table (copy-hash-table map)
 182     :array (seq-copy map)))
 183
 184 (defun map-apply (function map)
 185   "Apply FUNCTION to each element of MAP and return the result as a list.
 186 FUNCTION is called with two arguments, the key and the value.
 187
 188 MAP can be a list, hash-table or array."
 189   (funcall (map--dispatch map
 190              :list #'map--apply-alist
 191              :hash-table #'map--apply-hash-table
 192              :array #'map--apply-array)
 193            function
 194            map))
 195
 196 (defun map-keys-apply (function map)
 197   "Return the result of applying FUNCTION to each key of MAP.
 198
 199 MAP can be a list, hash-table or array."
 200   (map-apply (lambda (key _)
 201                (funcall function key))
 202              map))
 203
 204 (defun map-values-apply (function map)
 205   "Return the result of applying FUNCTION to each value of MAP.
 206
 207 MAP can be a list, hash-table or array."
 208   (map-apply (lambda (_ val)
 209                (funcall function val))
 210              map))
 211
 212 (defun map-filter (pred map)
 213   "Return an alist of the key/val pairs for which (PRED key val) is non-nil in MAP.
 214
 215 MAP can be a list, hash-table or array."
 216   (delq nil (map-apply (lambda (key val)
 217                          (if (funcall pred key val)
 218                              (cons key val)
 219                            nil))
 220                        map)))
 221
 222 (defun map-remove (pred map)
 223   "Return an alist of the key/val pairs for which (PRED key val) is nil in MAP.
 224
 225 MAP can be a list, hash-table or array."
 226   (map-filter (lambda (key val) (not (funcall pred key val)))
 227               map))
 228
 229 (defun map-p (map)
 230   "Return non-nil if MAP is a map (list, hash-table or array)."
 231   (or (listp map)
 232       (hash-table-p map)
 233       (arrayp map)))
 234
 235 (defun map-empty-p (map)
 236   "Return non-nil is MAP is empty.
 237
 238 MAP can be a list, hash-table or array."
 239   (map--dispatch map
 240     :list (null map)
 241     :array (seq-empty-p map)
 242     :hash-table (zerop (hash-table-count map))))
 243
 244 (defun map-contains-key-p (map key &optional testfn)
 245   "Return non-nil if MAP contain the key KEY, nil otherwise.
 246 Equality is defined by TESTFN if non-nil or by `equal' if nil.
 247
 248 MAP can be a list, hash-table or array."
 249   (seq-contains-p (map-keys map) key testfn))
 250
 251 (defun map-some-p (pred map)
 252   "Return a key/value pair for which (PRED key val) is non-nil in MAP.
 253
 254 MAP can be a list, hash-table or array."
 255   (catch 'map--break
 256     (map-apply (lambda (key value)
 257                  (when (funcall pred key value)
 258                    (throw 'map--break (cons key value))))
 259                map)
 260     nil))
 261
 262 (defun map-every-p (pred map)
 263   "Return non-nil if (PRED key val) is non-nil for all elements of the map MAP.
 264
 265 MAP can be a list, hash-table or array."
 266   (catch 'map--break
 267     (map-apply (lambda (key value)
 268                  (or (funcall pred key value)
 269                      (throw 'map--break nil)))
 270                map)
 271     t))
 272
 273 (defun map-merge (type &rest maps)
 274   "Merge into a map of type TYPE all the key/value pairs in the maps MAPS.
 275
 276 MAP can be a list, hash-table or array."
 277   (let (result)
 278     (while maps
 279       (map-apply (lambda (key value)
 280                    (map-put result key value))
 281                  (pop maps)))
 282     (map-into result type)))
 283
 284 (defun map-into (map type)
 285   "Convert the map MAP into a map of type TYPE.
 286
 287 TYPE can be one of the following symbols: list or hash-table.
 288 MAP can be a list, hash-table or array."
 289   (pcase type
 290     (`list (map-pairs map))
 291     (`hash-table (map--into-hash-table map))
 292     (t (error "Not a map type name: %S" type))))
 293
 294 (defun map--apply-alist (function map)
 295   "Private function used to apply FUNCTION over MAP, MAP being an alist."
 296   (seq-map (lambda (pair)
 297              (funcall function
 298                       (car pair)
 299                       (cdr pair)))
 300            map))
 301
 302 (defun map--apply-hash-table (function map)
 303   "Private function used to apply FUNCTION over MAP, MAP being a hash-table."
 304   (let (result)
 305     (maphash (lambda (key value)
 306                (push (funcall function key value) result))
 307              map)
 308     (nreverse result)))
 309
 310 (defun map--apply-array (function map)
 311   "Private function used to apply FUNCTION over MAP, MAP being an array."
 312   (let ((index 0))
 313     (seq-map (lambda (elt)
 314                (prog1
 315                    (funcall function index elt)
 316                  (setq index (1+ index))))
 317              map)))
 318
 319 (defun map--elt-list (map key &optional default)
 320   "Lookup, in the list MAP, the value associated with KEY and return it.
 321 If KEY is not found, return DEFAULT which defaults to nil."
 322   (let ((pair (assoc key map)))
 323     (if pair
 324         (cdr pair)
 325       default)))
 326
 327 (defun map--elt-array (map key &optional default)
 328   "Return the element of the array MAP at the index KEY.
 329 If KEY is not found, return DEFAULT which defaults to nil."
 330   (let ((len (seq-length map)))
 331     (or (and (>= key 0)
 332              (<= key len)
 333              (seq-elt map key))
 334         default)))
 335
 336 (defun map--delete-alist (map key)
 337   "Return MAP with KEY removed."
 338   (seq-remove (lambda (pair)
 339                 (equal key (car pair)))
 340               map))
 341
 342 (defun map--delete-array (map key)
 343   "Set nil in the array MAP at the index KEY if present and return MAP."
 344   (let ((len (seq-length map)))
 345     (and (>= key 0)
 346          (<= key len)
 347          (aset map key nil)))
 348   map)
 349
 350 (defun map--into-hash-table (map)
 351   "Convert MAP into a hash-table."
 352   (let ((ht (make-hash-table :size (map-length map)
 353                              :test 'equal)))
 354     (map-apply (lambda (key value)
 355                  (map-put ht key value))
 356                map)
 357     ht))
 358
 359 (defun map--make-pcase-bindings (args)
 360   "Return a list of pcase bindings from ARGS to the elements of a map."
 361   (seq-map (lambda (elt)
 362              (if (consp elt)
 363                  `(app (pcase--flip map-elt ',(car elt)) ,(cdr elt))
 364                `(app (pcase--flip map-elt ',elt) ,elt)))
 365            args))
 366
 367 (defun map--make-pcase-patterns (args)
 368   "Return a list of `(map ...)' pcase patterns built from ARGS."
 369   (cons 'map
 370         (seq-map (lambda (elt)
 371                    (if (and (consp elt) (eq 'map (car elt)))
 372                        (map--make-pcase-patterns elt)
 373                      elt))
 374                  args)))
 375
 376 (provide 'map)
 377 ;;; map.el ends here