(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))))))