cc8390ee |
;;;; fwoar.lisputils.lisp
(in-package #:fwoar.lisputils)
|
07f6eaf7 |
(defmacro neither (&rest forms) `(not (or ,@forms)))
(defmacro neither-null (&rest forms)
`(neither ,@(loop for form
in forms
collecting `(null ,form))))
|
c0730f1a |
(defmacro let-each ((&key (be '*)) &body forms)
"Bind each element successively to the symbol specified via :be"
`(let* ,(loop for form in forms
collect (list be form))
,be))
|
9c529e1a |
(defmacro let-first ((&key (be '*)) bound &body forms)
|
c0730f1a |
"Bind the result of the first form to the symbol specified via :be"
|
9c529e1a |
`(let* ((,be ,bound))
,@forms
|
c0730f1a |
,be))
(defmacro let-second ((&key (be '*)) &body forms)
"Bind the result of the second form to the symbol specified via :be"
`(progn
,(car forms)
(let* ((,be ,(cadr forms)))
|
9c529e1a |
,@(cddr forms)
|
c0730f1a |
,be)))
|
cc8390ee |
(defmacro lambda-if ((test &rest args) &body body)
"Make a lambda that wraps an call to if"
`(lambda ,args
(if (,test ,@args)
,@body)))
(defmacro lambda-cond ((&rest args) &body body)
"Make a lambda that wraps an call to cond"
`(lambda ,args
(cond
,@body)))
(defmacro alambda (&body body)
|
c4b8ada4 |
`(lambda (anaphora:it)
(declare (ignorable anaphora:it))
|
cc8390ee |
,@body))
|
e5349999 |
(eval-when (:compile-toplevel :load-toplevel :execute)
|
e143b109 |
(defun map-cons (cb cons)
(cond
((null cons) '())
((consp (cdr cons)) (cons (funcall cb (car cons))
(map-cons cb (cdr cons))))
(t (list (funcall cb (car cons))
(funcall cb (cdr cons))))))
(defun generate-declarations-for (sym ignored ignorable)
(let ((ignores (list))
(ignorables (list)))
(map-cons (op (cond ((member _1 ignorable)
(push _1 ignorables))
((member _1 ignored)
(push _1 ignores))))
(ensure-cons sym))
(if (or ignores ignorables)
`((declare
,@(when ignores
`((ignore ,@ignores)))
,@(when ignorables
`((ignorable ,@ignorables)))))
'())))
(defun find-ignored-vars (body)
(let ((possible-declarations (car body))
(ignored-vars nil)
(ignorable-vars nil))
|
334428a3 |
(if (and (consp possible-declarations)
(eq (car possible-declarations) 'declare)
|
e143b109 |
(consp (cadr possible-declarations)))
(let* ((declarations (cdr possible-declarations)))
(setf ignored-vars (cdr (assoc 'ignore declarations))
ignorable-vars (cdr (assoc 'ignorable declarations))
body (cdr body))))
(values ignored-vars
ignorable-vars
body)))
|
cc8390ee |
(defun ensure-mapping (list)
"Take a list and make sure that it's parseable as a let-style binding.
Very handy for certain sorts of macros."
(let ((symbols->mappings (lambda-cond (x)
|
e143b109 |
((symbolp x) `(,x ,x))
((null (cdr x)) `(,#1=(car x) ,#1#))
(t x))))
|
cc8390ee |
(mapcar symbols->mappings list)))
|
e5349999 |
|
e143b109 |
(defun rollup-list (list &optional body)
(labels ((helper (list &optional accum start)
(tagbody
start
(cond
((endp list) (return-from rollup-list accum))
(t (psetf accum (cond
((null accum) (car list))
(start `(,@(car list) ,@accum))
(t `(,@(car list) ,accum)))
list (cdr list)
start nil)
;; NOTE: REMEMBER! This call to #'GO is the "tail call"
(go start))))))
(helper (reverse list) body t))))
|
cc8390ee |
|
07f6eaf7 |
(defmacro m-lambda (sym &rest args)
(let ((arglist (loop for x in args
|
e143b109 |
unless (member x (list '&optional '&key '&rest))
collect (ctypecase x
(cons (car x))
((or symbol keyword string) x)))))
|
07f6eaf7 |
`(lambda (,@args)
(,sym ,@arglist))))
|
cc8390ee |
(defmacro destructuring-lambda ((&rest args) &body body)
"A lambda whose arguments can be lambda-lists to be destructured"
|
e143b109 |
(multiple-value-bind (ignored ignorable body) (find-ignored-vars body)
(let* ((args-syms (mapcar (lambda (_) (declare (ignore _)) (gensym "arg"))
args))
(args (mapcar #'list args args-syms))
(destructuring-expressions
(rollup-list
(loop for (arg arg-sym) in args
collect (if (consp arg)
`(destructuring-bind ,arg ,arg-sym
,@(generate-declarations-for arg ignored ignorable))
`(let ((,arg ,arg-sym))
,@(generate-declarations-for arg ignored ignorable))))
body)))
`(lambda ,args-syms
,destructuring-expressions))))
|
cc8390ee |
|
e5349999 |
;;; CASES:::
#|
(fw.lu::destructuring-lambda ((slot slot-keyword . r))
(make-slot-spec slot slot-keyword))
(fw.lu::destructuring-lambda ((slot slot-keyword . r))
(declare (ignore r))
(make-slot-spec slot slot-keyword))
(fw.lu::destructuring-lambda ((slot slot-keyword . r) b c)
(make-slot-spec slot slot-keyword))
(fw.lu::destructuring-lambda ((slot slot-keyword . r) b)
(make-slot-spec slot slot-keyword))
(fw.lu::destructuring-lambda ((slot slot-keyword . r) b)
(declare (ignore r))
(make-slot-spec slot slot-keyword))
|#
|
cc8390ee |
(defun alist-string-hash-table (alist)
"Make a hash table suitable for strings and other non-eql types
from an association list"
(alexandria:alist-hash-table alist :test #'equal))
(defmacro copy-slots (slots from to)
"Given a list of slots specified as let-style bindings, copy them
from one object to another."
(once-only (from to)
`(progn
|
aabf976a |
(setf ,@(apply #'append
|
3f1c9190 |
(iterate:iterate (for (fro-slot to-slot) in (ensure-mapping slots))
(collect `((slot-value ,to ',to-slot) (slot-value ,from ',fro-slot))))))
|
cc8390ee |
,to)))
(defun transform-alist (function alist)
"Run down an alist, applying a given function to each element"
(mapcar (destructuring-lambda ((k . v)) (funcall function k v))
alist))
(defun %json-pair-transform (k v)
"Ugly hack to make jonathan work correctly with string values.
TODO: move this elsewhere"
(cons (make-keyword (string-downcase k))
(typecase v
(string (coerce v 'simple-string))
(t v))))
(defun %default-pair-transform (k v)
(cons (make-keyword (string-upcase k)) v))
(defmacro default-when (default test &body body)
|
222e6786 |
"return the default unless the test is true"
(warn "default-when is deprecated, renamed to default-unless")
(once-only (default)
`(or (when ,test
,@body)
,default)))
(defmacro default-unless (default test &body body)
|
cc8390ee |
"return the default unless the test is true"
(once-only (default)
`(or (when ,test
,@body)
,default)))
(defmacro transform-result ((list-transform &optional (pair-transform #'identity)) &rest alist)
"Transform an alist that results from some operation as a whole and, optionally, apply a
transformation to each key-value pair."
`(funcall ,list-transform (transform-alist ,pair-transform ,@alist)))
(defun make-pairs (symbols)
;TODO: does this duplicate ensure-mapping?
(cons 'list
|
3f1c9190 |
(iterate:iterate (iterate:for (key value) in symbols)
(iterate:collect `(list* ,(symbol-name key) ,value)))))
|
cc8390ee |
(defmacro slots-to-pairs (obj (&rest slots))
"Produce a alist from a set of object slots and their values"
(once-only (obj)
(let* ((slots (ensure-mapping slots))
|
3f1c9190 |
(bindings (iterate:iterate (iterate:for (slot v &key bind-from) in slots)
(iterate:collect (or bind-from slot)))))
|
cc8390ee |
`(with-slots ,bindings ,obj
,(make-pairs slots)))))
(defun normalize-html (html)
"Convert possibly bad HTML to sane HTML as best as possible."
(let ((plump:*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)))))
|
a16eb0ec |
(defmacro setfs (&body body)
"Make setf a bit nicer to use with paredit"
(list* 'setf (apply #'append body)))
|
e143b109 |
(defmacro prog2-let (first-form (&rest result-binding) &body body)
"Execute a form, make a bunch of bindings and retern the bound values via prog1 after executing body"
`(progn ,first-form
(let (,@result-binding)
(prog1 (list ,@(mapcar #'car result-binding))
,@body))))
|
0052b5eb |
;; TODO: use multiple values . . .
|
21620473 |
(defmacro prog1-let ((&rest result-binding) &body body)
|
e143b109 |
"Bind a bunch of symbols to values and return them via prog1"
|
21620473 |
`(let (,@result-binding)
(prog1 (list ,@(mapcar #'car result-binding))
,@body)))
|
e4551d8e |
(defmacro prog1-bind ((var val) &body body)
`(let ((,var ,val))
(prog1 ,var
,@body)))
|
e143b109 |
(defmacro if-let* ((&rest bindings) &body (then-form &optional else-form))
"Like if-let, but sets bindings sequentially. Doesn't short-circuit."
`(let* ,bindings
(if (and ,@(mapcar #'car bindings))
,then-form
,else-form)))
(defmacro with ((var val) &body body)
"A stripped down let for binding a single name"
`(let ((,var ,val))
,@body))
|
df7955ae |
(flet ((do-acons (alist key datum)
(acons key datum alist)))
(define-modify-macro aconsf (key datum) do-acons))
|
e143b109 |
;(defun ensure-list (val)
; (typecase val
; (list val)
; (t (list val))))
|
a16eb0ec |
|
3f1c9190 |
(defun map-tree* (fun tree &optional (tag nil tagp))
"Walk FUN over TREE and build a tree from the results.
The new tree may share structure with the old tree.
(eq tree (map-tree #'identity tree)) => T
FUN can skip the current subtree with (throw TAG SUBTREE), in which
case SUBTREE will be used as the value of the subtree."
(let ((fun (ensure-function fun)))
(labels ((map-tree (tree)
(let ((tree2 (funcall fun tree)))
(if (atom tree2)
tree2
(serapeum::reuse-cons (map-tree (car tree2))
(map-tree (cdr tree2))
tree2))))
(map-tree/tag (tree tag)
(catch tag
(let ((tree2 (funcall fun tree)))
(if (atom tree2)
tree2
(serapeum::reuse-cons (map-tree/tag (car tree2) tag)
(map-tree/tag (cdr tree2) tag)
tree2))))))
(if tagp
(map-tree/tag tree tag)
(map-tree tree)))))
(defun replace-subtree (predicate value tree)
(let ((spliced-value nil))
(flet ((mapper (x)
(typecase x
(cons
(if (funcall predicate x)
(progn
(setf spliced-value x)
(throw 'bail value))
x))
(t x))))
(let ((result (map-tree* #'mapper tree 'bail)))
(values result spliced-value)))))
|
e4551d8e |
|