(in-package #:fwoar.lisputils)
(defmacro neither (&rest forms)
`(not (or ,@forms)))
(defmacro neither-null (&rest forms)
`(neither ,@(loop for form
in forms
collecting `(null ,form))))
(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))
(defmacro let-first ((&key (be '*)) bound &body forms)
"Bind the result of the first form to the symbol specified via :be"
`(let* ((,be ,bound))
,@forms
,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)))
,@(cddr forms)
,be)))
(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)
`(lambda (anaphora:it)
(declare (ignorable anaphora:it))
,@body))
(eval-when (:compile-toplevel :load-toplevel :execute)
(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 (lambda (_1)
(cond ((member _1 ignorable)
(push _1 ignorables))
((member _1 ignored)
(push _1 ignores))))
(alexandria: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))
(if (and (consp possible-declarations)
(eq (car possible-declarations) 'declare)
(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)))
(defun ensure-mapping (list &optional (key-fn 'identity))
"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)
((symbolp x) `(,(funcall key-fn x) ,x))
((null (cdr x)) `(,(funcall key-fn #1=(car x)) ,#1#))
(t x))))
(mapcar symbols->mappings list)))
(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))))
(defmacro m-lambda (sym &rest args)
(let ((arglist (loop for x in args
unless (member x (list '&optional '&key '&rest))
collect (ctypecase x
(cons (car x))
((or symbol keyword string) x)))))
`(lambda (,@args)
(,sym ,@arglist))))
(defun get-ignored-vars (body)
(let ((declarations (cdr (assoc 'declare body))))
(values (cdr (assoc 'ignore declarations))
(cdr (assoc 'ignorable declarations)))))
(defmacro destructuring-lambda ((&rest args) &body body)
"A lambda whose arguments can be lambda-lists to be destructured"
(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
(declare (ignore ,@ignored) (ignorable ,@ignorable)))
`(let ((,arg ,arg-sym))
,@(generate-declarations-for arg ignored ignorable))))
body)))
`(lambda ,args-syms
,destructuring-expressions))))
;;; 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))
|#
(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."
(alexandria:once-only (from to)
`(progn
(setf ,@(apply #'append
(iterate:iterate
(iterate:for (fro-slot to-slot) iterate:in (ensure-mapping slots))
(iterate:collect `((slot-value ,to ',to-slot) (slot-value ,from ',fro-slot))))))
,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 (alexandria:make-keyword (string-downcase k))
(typecase v
(string (coerce v 'simple-string))
(t v))))
(defun %default-pair-transform (k v)
(cons (alexandria:make-keyword (string-upcase k)) v))
(defun find-nonoperator-symbols (form)
(alexandria:flatten
(remove-duplicates
(typecase form
(symbol (list form))
(cons (append
(when (consp (car form))
(find-nonoperator-symbols (car form)))
(typecase (cdr form)
(symbol (list (cdr form)))
(cons (loop for thing in (cdr form)
append (find-nonoperator-symbols thing))))))))))
(defmacro may ((op arg &rest r))
(let ((cond (case op
(cl:funcall (car r))
(t arg))))
(alexandria:once-only (arg)
`(when ,cond
(,op ,arg ,@r)))))
(defmacro default-when (default test &body body)
"return the default unless the test is true"
(warn "default-when is deprecated, renamed to default-unless")
(alexandria:once-only (default)
`(or (when ,test
,@body)
,default)))
(defmacro default-unless (default test &body body)
"return the default unless the test is true"
(alexandria: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
(iterate:iterate
(iterate:for (key value) in symbols)
(iterate:collect `(list* ,(symbol-name key) ,value)))))
(defun inits (l)
(serapeum:with-collector (c)
(let ((its ()))
(mapc (lambda (it)
(push it its)
(c (reverse its)))
l))))
(defmacro closing ((op &rest args))
(let ((stream-sym (gensym "STRING")))
`(with-open-stream (,stream-sym ,(first args))
(,op ,stream-sym ,@(cdr args)))))
#+fw.ignore
(progn
(closing (read-line (open "/foo/bar"
:element-type '(unsigned-byte 8))
nil
:the-end))
)
(defmacro slots-to-pairs (obj (&rest slots))
(declare (optimize (debug 3)))
"Produce a alist from a set of object slots and their values"
(alexandria:once-only (obj)
(let* ((slots (ensure-mapping slots))
(bindings (iterate:iterate
(iterate:for (slot v &key bind-from) in slots)
(iterate:collect (or bind-from slot)))))
`(with-slots ,bindings ,obj
,(make-pairs slots)))))
(defmacro setfs (&body body)
"Make setf a bit nicer to use with paredit"
(list* 'setf (apply #'append body)))
(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))))
;; TODO: use multiple values . . .
(defmacro prog1-let ((&rest result-binding) &body body)
"Bind a bunch of symbols to values and return them via prog1"
`(let (,@result-binding)
(multiple-value-prog1 (values ,@(mapcar #'car result-binding))
,@body)))
(defmacro prog1-bind ((var val) &body body)
`(let ((,var ,val))
(prog1 ,var
,@body)))
(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))
(defun do-acons (alist key datum)
(acons key datum alist))
(define-modify-macro aconsf (key datum) do-acons)
(defun do-adjoin (list item &rest r &key key test test-not)
(declare (ignore key test test-not))
(apply #'adjoin item list r))
(define-compiler-macro do-adjoin (list item &rest r)
(alexandria:once-only (list item)
`(adjoin ,item ,list ,@r)))
(define-modify-macro adjoinf (item &rest r)
do-adjoin)
;;(defun ensure-list (val)
;; (typecase val
;; (list val)
;; (t (list val))))
(defmacro defun-ct (name (&rest args) &body body)
`(eval-when (:load-toplevel :compile-toplevel :execute)
(defun ,name ,args
,@body)))
(defmacro retry-once (&body body)
(alexandria:with-gensyms (flag)
`(let ((,flag t))
(tagbody
start
,@body
(when ,flag
(setf ,flag nil)
(go start))))))