/src/utils.lisp

http://github.com/sykopomp/chillax · Lisp · 80 lines · 62 code · 11 blank · 7 comment · 6 complexity · 0da6da5045ab04f506369b9cb790a941 MD5 · raw file

  1. (cl:defpackage :chillax.utils
  2. (:use :cl :alexandria)
  3. (:export
  4. :fun :mkhash :hashget :strcat :dequote :at))
  5. (in-package :chillax.utils)
  6. ;;; Functions
  7. (defmacro fun (&body body)
  8. "This macro puts the FUN back in FUNCTION."
  9. `(lambda (&optional _) (declare (ignorable _)) ,@body))
  10. ;;; Hash tables
  11. (defun mkhash (&rest keys-and-values &aux (table (make-hash-table :test #'equal)))
  12. "Convenience function for `literal' hash table definition."
  13. (loop for (key val) on keys-and-values by #'cddr do (setf (gethash key table) val)
  14. finally (return table)))
  15. (defun hashget (hash &rest keys)
  16. "Convenience function for recursively accessing hash tables."
  17. (reduce (lambda (h k) (gethash k h)) keys :initial-value hash))
  18. (define-compiler-macro hashget (hash &rest keys)
  19. (if (null keys) hash
  20. (let ((hash-sym (make-symbol "HASH"))
  21. (key-syms (loop for i below (length keys)
  22. collect (make-symbol (format nil "~:@(~:R~)-KEY" i)))))
  23. `(let ((,hash-sym ,hash)
  24. ,@(loop for key in keys for sym in key-syms
  25. collect `(,sym ,key)))
  26. ,(reduce (lambda (hash key) `(gethash ,key ,hash))
  27. key-syms :initial-value hash-sym)))))
  28. (defun (setf hashget) (new-value hash key &rest more-keys)
  29. "Uses the last key given to hashget to insert NEW-VALUE into the hash table
  30. returned by the second-to-last key.
  31. tl;dr: DWIM SETF function for HASHGET."
  32. (if more-keys
  33. (setf (gethash (car (last more-keys))
  34. (apply #'hashget hash key (butlast more-keys)))
  35. new-value)
  36. (setf (gethash key hash) new-value)))
  37. ;;; Strings
  38. (defun strcat (string &rest more-strings)
  39. (apply #'concatenate 'string string more-strings))
  40. (defun dequote (string)
  41. (let ((len (length string)))
  42. (if (and (> len 1) (starts-with #\" string) (ends-with #\" string))
  43. (subseq string 1 (- len 1))
  44. string)))
  45. ;;;
  46. ;;; At
  47. ;;;
  48. (defgeneric at (doc &rest keys))
  49. (defgeneric (setf at) (new-value doc key &rest more-keys))
  50. (defmethod at ((doc hash-table) &rest keys)
  51. (apply #'hashget doc keys))
  52. (defmethod (setf at) (new-value (doc hash-table) key &rest more-keys)
  53. (apply #'(setf hashget) new-value doc key more-keys))
  54. (defmethod at ((doc list) &rest keys)
  55. (reduce (lambda (alist key)
  56. (cdr (assoc key alist :test #'equal)))
  57. keys :initial-value doc))
  58. (defmethod (setf at) (new-value (doc list) key &rest more-keys)
  59. (if more-keys
  60. (setf (cdr (assoc (car (last more-keys))
  61. (apply #'at doc key (butlast more-keys))
  62. :test #'equal))
  63. new-value)
  64. (setf (cdr (assoc key doc :test #'equal)) new-value)))
  65. ;; A playful alias.
  66. (defun @ (doc &rest keys)
  67. (apply #'at doc keys))
  68. (defun (setf @) (new-value doc key &rest more-keys)
  69. (apply #'(setf at) new-value doc key more-keys))