git.fiddlerwoaroof.com
utils.lisp
89bed873
 (in-package whitespace.utils)
17e50f7b
 
 (defun ensure-mapping (list)
   "Make sure that each item of the list is a pair of symbols"
   (mapcar (lambda (x) (if (symbolp x) (list x x) x)) list))
 (export 'ensure-mapping)
 
 (defun alist-string-hash-table (alist)
   (alexandria:alist-hash-table alist :test #'string=))
 (export 'alist-string-hash-table)
 
 (defun make-pairs (symbols)
   (cons 'list (iterate (for (key value) in symbols)
                        (collect (list 'list* (symbol-name key) value)))))
 (export 'make-pairs)
 
 (defmacro copy-slots (slots from-v to-v)
   (with-gensyms (from to)
     `(let ((,from ,from-v) (,to ,to-v))
        ,@(iterate (for (fro-slot to-slot) in (ensure-mapping slots))
                   (collect `(setf (slot-value ,to ',to-slot) (slot-value ,from ',fro-slot))))
        ,to)))
 (export 'copy-slots)
 
 
 (defun transform-alist (pair-transform alist)
   (iterate (for (k . v) in-sequence alist)
            (collect
              (funcall pair-transform k v))))
 (export 'transform-alist)
 
 (defun %json-pair-transform (k v)
   (cons (make-keyword (string-downcase k))
         (typecase v
           (string (coerce v 'simple-string))
           (t v))))
 (export '%json-pair-transform)
 
 (defun %default-pair-transform (k v)
   (cons (make-keyword (string-upcase k)) v))
 (export '%default-pair-transform)
 
 (defmacro default-when (default test &body body)
   (once-only (default)
     `(or (when ,test
            ,@body)
          ,default)))
 (export 'default-when)
 
 (defmacro transform-result ((list-transform pair-transform) &body alist)
   `(funcall ,list-transform
             (transform-alist ,pair-transform
                              ,@alist)))
 (export 'transform-result)
 
 
 (defmacro slots-to-pairs (obj (&rest slots))
   (once-only (obj)
     (let* ((slots (ensure-mapping slots))
            (bindings (iterate (for (slot v &key bind-from) in slots)
                               (collect (or bind-from slot)))))
       `(with-slots ,bindings ,obj
          ,(make-pairs slots)))))
 (export 'slots-to-pairs)
89bed873
 
b99dd5be
 (defun normalize-html (html)
   (let ((plump-parser:*tag-dispatchers* plump:*html-tags*))
     (with-output-to-string (ss)
       (prog1 ss
         (map 'vector
            (lambda (x) (plump:serialize (plump:parse (plump:text x)) ss))
            html)))))
 (export 'normalize-html)
89bed873