;;;    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;       Collection of usefull tools ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(cl:defpackage tools
  (:use cl)
  (:export compiler-policy doc))

(in-package tools)

(defun compiler-policy (safety debug speed)
  "Sets SBCL's compiler policies safety, debug and speed."
  (sb-ext:restrict-compiler-policy 'safety safety)
  (sb-ext:restrict-compiler-policy 'debug debug)
  (sb-ext:restrict-compiler-policy 'speed speed))

(defmacro doc (function)
  "Looking up documentation of function."
  `(documentation ',function 'function))

(defun remove* (symbol tree)
  "Removes symbol from tree."
  (cond
    ((null tree) tree)
    ((atom (car tree))
     (if (equalp symbol (car tree))
         (remove* symbol (cdr tree))
         (cons (car tree) (remove* symbol (cdr tree)))))
    (t (cons (remove* symbol (car tree))
             (remove* symbol (cdr tree))))))

(defun replace* (old new tree)
  "Replaces old with new symbol in tree."
  (cond
    ((null tree) tree)
    ((atom (car tree))
     (if (equalp old (car tree))
         (cons new (replace* old new (cdr tree)))
         (cons (car tree) (replace* old new (cdr tree)))))
    (t (cons (replace* old new (car tree))
             (replace* old new (cdr tree))))))

(defmacro once-only ((&rest names) &body body)
  "Macro once-only from Peter Seibel in PCL."
  (let ((gensyms (loop for n in names collect (gensym))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
          ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
                ,@body)))))


(defun partial (fn &rest args)
  "Returns function FN with partial binded parameters ARGS."
  (lambda (&rest more-args)
    (apply fn (append args more-args))))

(defmacro with-partial-macro (name macro list-of-args &body body)
  "TODO: docu"
  `(macrolet ((,name (more-args)
                `(,,macro ,,@list-of-args ,@more-args)))
     ,@body))

(defmacro testmacro (&rest args)
  `(+ ,@args))

;;; TOOLS> (macroexpand-1 '(with-partial-macro partial-plus testmacro (1 2 3)
;;;                         (partial-plus 4 5 6)))
;;;
;;; (MACROLET ((PARTIAL-PLUS (MORE-ARGS)
;;;              `(,TESTMACRO ,1 ,2 ,3 ,@MORE-ARGS)))
;;;   (PARTIAL-PLUS 4 5 6))


;;; should expand to:
;;; (macrolet ((meinname (more-args)
;;;   '(testmacro 1 2 3 ,@more-args))))

(defmacro test (list-of-args &body body)
  `(macrolet ((mytest (&args more-args)
              `(testmacro ,,@list-of-args ,@more-args)))
     ,body))


(defmacro my-destructuring-bind (lambda-list list &body body)
  "Allows to use the symbol _ as a placeholder
when using destructurin-bind.
this
 (macroexpand-1 '(my-destructuring-bind (s1 _ s2 &optional _) '(1 2 3)
                  (list s1 s2)))
expands to
 (DESTRUCTURING-BIND
     (S1 #:G1057 S2 &OPTIONAL #:G1058)
     '(1 2 3)
   (DECLARE (IGNORE #:G1057 #:G1058))
   (LIST S1 S2))"
  (let (new-lambda-list ignore-symbols-list)
    (dolist (symbol lambda-list)
      (if (eq '_ symbol)
          (let ((gsym (gensym)))
            (push gsym ignore-symbols-list)
            (push gsym new-lambda-list))
          (push symbol new-lambda-list)))
    `(destructuring-bind ,(nreverse new-lambda-list) ,list
         (declare (ignore ,@(nreverse ignore-symbols-list)))
         ,@body)))

;;;    macro for defining recursive expressions
(defmacro lambda*% (args &rest body)
  `(lambda ,args
     (labels ((recur ,args ,@body))
       (recur ,@args))))

(defmacro lambda* (fname args &rest body)
  `(lambda ,args
     (labels ((,fname ,args ,@body))
       (fname ,@args))))

(defmacro lambda*%% (fname args &rest body)
  (let ((evaluated-args (gensym)))
    `(lambda ,args
       (let ((evaluated-args ,args))
         (labels ((,fname ,evaluated-args ,@body))
           (fname ,@evaluated-args))))))

(defmacro lambda*%%% (fname args &rest body)
  (let ((evaluated-args (gensym)))
    `(lambda ,evaluated-args
       (let ((,evaluated-args args))
         (labels ((,fname ,evaluated-args ,@body))
           (fname ,@evaluated-args))))))