bat/tests/syntax-tests/highlighted/Lisp/utils.lisp
2020-10-16 08:58:04 +02:00

81 lines
20 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

(cl:defpackage :chillax.utils
 (:use :cl :alexandria)
 (:export
 :fun :mkhash :hashget :strcat :dequote :at))
(in-package :chillax.utils)
;;; Functions
(defmacro fun (&body body)
 "This macro puts the FUN back in FUNCTION."
 `(lambda (&optional _) (declare (ignorable _)) ,@body))
;;; Hash tables
(defun mkhash (&rest keys-and-values &aux (table (make-hash-table :test #'equal)))
 "Convenience function for `literal' hash table definition."
 (loop for (key val) on keys-and-values by #'cddr do (setf (gethash key table) val)
 finally (return table)))
(defun hashget (hash &rest keys)
 "Convenience function for recursively accessing hash tables."
 (reduce (lambda (h k) (gethash k h)) keys :initial-value hash))
(define-compiler-macro hashget (hash &rest keys)
 (if (null keys) hash
 (let ((hash-sym (make-symbol "HASH"))
 (key-syms (loop for i below (length keys)
 collect (make-symbol (format nil "~:@(~:R~)-KEY" i)))))
 `(let ((,hash-sym ,hash)
 ,@(loop for key in keys for sym in key-syms
 collect `(,sym ,key)))
 ,(reduce (lambda (hash key) `(gethash ,key ,hash))
 key-syms :initial-value hash-sym)))))
(defun (setf hashget) (new-value hash key &rest more-keys)
 "Uses the last key given to hashget to insert NEW-VALUE into the hash table
returned by the second-to-last key.
tl;dr: DWIM SETF function for HASHGET."
 (if more-keys
 (setf (gethash (car (last more-keys))
 (apply #'hashget hash key (butlast more-keys)))
 new-value)
 (setf (gethash key hash) new-value)))
;;; Strings
(defun strcat (string &rest more-strings)
 (apply #'concatenate 'string string more-strings))
(defun dequote (string)
 (let ((len (length string)))
 (if (and (> len 1) (starts-with #\" string) (ends-with #\" string))
 (subseq string 1 (- len 1))
 string)))
;;;
;;; At
;;;
(defgeneric at (doc &rest keys))
(defgeneric (setf at) (new-value doc key &rest more-keys))
(defmethod at ((doc hash-table) &rest keys)
 (apply #'hashget doc keys))
(defmethod (setf at) (new-value (doc hash-table) key &rest more-keys)
 (apply #'(setf hashget) new-value doc key more-keys))
(defmethod at ((doc list) &rest keys)
 (reduce (lambda (alist key)
 (cdr (assoc key alist :test #'equal)))
 keys :initial-value doc))
(defmethod (setf at) (new-value (doc list) key &rest more-keys)
 (if more-keys
 (setf (cdr (assoc (car (last more-keys))
 (apply #'at doc key (butlast more-keys))
 :test #'equal))
 new-value)
 (setf (cdr (assoc key doc :test #'equal)) new-value)))
;; A playful alias.
(defun @ (doc &rest keys)
 (apply #'at doc keys))
(defun (setf @) (new-value doc key &rest more-keys)
 (apply #'(setf at) new-value doc key more-keys))