;;;; hyperquirks.lisp

(in-package #:hyperquirks)

;;; MACROS

(defmacro with-env ((&rest bindings) &body body)
  (let ((bindings
          (loop :for binding :in bindings
                :collect (list* (gensym "VAR") (gensym "VAL") binding))))
    `(let* ,(loop :for (oldval cacheval envvar newval) :in bindings
                  :collect `(,oldval (uiop:getenv ,envvar))
                  :collect `(,cacheval ,newval))
       (setf ,@(loop :for (oldval cacheval envvar newval) :in bindings
                     :collect `(uiop:getenv ,envvar)
                     :collect cacheval))
       (unwind-protect (progn ,@body)
         ,@(loop :for (oldval cacheval envvar newval) :in (reverse bindings)
                 :collect `(when ,oldval
                             (setf (uiop:getenv ,envvar) ,oldval)))))))

(defmacro let+ (bindings &body body)
  "General purpose binding. Normal let bindings, destructuring-binds,
and multiple-value-binds all in the same form.

(let+ ((x
         10)
       ((y z . w) 
           (list 1 2 3 4 5)) 
       (p q r 
           (values :oh :my :goodness))) 

  (list x y x w p q r))

;; returns
(10 1 2 (3 4 5) :oh :my :goodness)
"
  (flet ((destructuring-binding-p (binding)
           (and (consp (first binding))
                (every #'symbolp (first binding))))
         (mvb-binding-p (binding)
           (and (every #'symbolp (butlast binding))
                (consp (first (last binding))))))
    (loop
      :with body = `(progn ,@body)
      :for binding :in (reverse bindings)
      :when (destructuring-binding-p binding)
        :do (setf body
                  `(destructuring-bind ,(first binding) ,(second binding)
                     ,body))
      :when (mvb-binding-p binding)
        :do (setf body
                  `(multiple-value-bind
                         ,(butlast binding) ,(first (last binding))
                     ,body))
      :finally (return body))))

(defmacro imperative (&body body)
   "Evaluate expressins in BODY in sequence. Expressions that look
 like (:= VAR1 EXPR1 ...) will expand into a LET* form whose bindings
 are valid for the rest of the BODY

 E.g.

 (imperative 
   (format t \"Welcome to IMPERATIVE\") 
   (terpri)
   (:= x 10 z (+ x 20))
   (format t \"X = ~a, Z = ~a~%\" x z)
   (:= y (+ z 20))
   (format t \"Y = ~a~%\" y)
   (list x y z))

 would evaluate to:

 Welcome to IMPERATIVE    ;; <-- printed to stdout
 X = 10, Z = 30
 Y = 50
 
(10 50 30)     ;; <-- return value

IMPERATIVE introduces an implicit, anonymous BLOCK, and hence can be
returned from.
 "
   (labels ((binding-form-p (form)
              (and (consp form)
                   (keywordp (first form))
                   (eql := (first form))))
            (collect-bindings (bindings)
              (loop for (var expr . more) on bindings by #'cddr
                    collect (list var expr)))
            (expander (body)
              (cond
                ((null body) body)
                ((binding-form-p (first body))
                 (list (list* 'let* (collect-bindings (rest (first body)))
                              (expander (rest body)))))
                (t
                 (cons (first body)
                       (expander (rest body)))))))
     `(block () ,@(expander body))))


(defmacro $> (input-form &rest functions)
  (loop :with sub = input-form
        :for next-form :in piped-to-forms
        :when (symbolp next-form)
          :do (setf sub `(funcall ,next-form ,sub))
        :when (consp next-form)
          :do (setf sub `(,(first next-form) ,sub ,@(rest next-form)))
        :finally (return sub )))


(defmacro binding-cond (&body clauses)
  "Like cond except the first form of every clause is a binding form
alá IMPERATIVE. 

E.g. 

(binding-cond 
   ((:= x (and (zerop (random 2)) 10)
        y 11)
    (list :x x :y y))
   (t
     12))


That would bind x and y in the first clause, check both both are non
nil, and if they are, return the evaluated body, in this case (list :x x :y y)

Otherwise 12 would be returned."

  (let ((imperative-body 
          (loop for (bindings . body) in clauses
                for vars = (unless (eq t bindings)
                             (loop for (var _ . more) on (rest bindings) by #'cddr
                                   collect var))
                collect bindings
                collect `(when (and ,@vars) (return (progn ,@body))))))
    `(imperative ,@imperative-body)))




(defmacro defun-case (name &rest clauses)
  "Clauses look like (VARLIST . BODY) 

E.g. 

(defun-case foobar 
  (() 10) 
  ((x y) (+ x y))
  ((foo) (* foo 2))
  ((a b c d) (list a b c d)))"
  (let* ((rest-args
           (gensym "variable-pattern-"))
         (clauses
           (loop for (arglist . body) in clauses
                 collect `(,(length arglist)
                           (destructuring-bind ,arglist ,rest-args
                             ,@body)))))
    `(defun ,name (&rest ,rest-args)
       (case (length ,rest-args)
         ,@clauses))))