path: root/hyperquirks.lisp

;;;; hyperquirks.lisp

(in-package #:hyperquirks)

;;; MACROS

(defmacro with-env ((&rest bindings) &body body)
  "Execute BODY in context where environment variables are bound to
particular values.  When BODY finishes executing, or exits early, the
environment variables are restored to their original values.

EXAMPLE:

(with-env ((\"VAR1\" (get-value-for-var))
           (\"VAR2\" \"SOME_VAL\"))
  (print (uiop:getenv \"VAR1\"))
  (print (uiop:getenv \"VAR2\")))"
  (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 (or (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))))

(eval-when (:compile-toplevel :load-toplevel :execute) 
  (defun flatten (ls)
    (if (atom ls) (list ls)
        (mapcan #'flatten ls))))

(defmacro >> ((&key
                 (prefix "_")
                 (block (gensym ">>BLOCK-"))
                 fail)
              initform &rest pipe-forms)
  "Pipe a value through a series of forms and function calls. 

For Example:

(>> () 10 +1 write-to-string (format nil \"~a-wut\" _arg))

expands into, roughly:

(FORMAT NIL \"~a-wut?\" (FUNCALL 'WRITE-TO-STRING (FUNCALL '1+ 10)))

and evaluates to

\"11-wut?\"

In the above, _ARG is a substitution variable. The macro uses
substitution variables to nest the accumlated expression into the form
that contains the variable.

PREFIX is a string or symbol that indicates the prefix to substitution
variables.

PIPE-FORMS, as in the example above, must be either (1) a symbol that
names a function, or (2) a tree containing exactly one substitution
variable.

The same substitution variable can appear more than once in a pipe
form. When they do, the value of the previous form is passed into all
instances is substituted in.

However, two different substitution variables CANNOT APPEAR in a
single pipe form.

This macro accepts additional syntax: the :? form standing on its own
indicates the the next form shold be a predicate that, if it evaluates
to NIL, causes an early exit, with failure state FAIL.  

E.g.

(>> (:fail :oh-no!)
  (random 10)      ; start with a random number
  :? evenp         ; exit with :oh-no! unless even
  (+ 10 _))        ; add 10 and return."
  (let ((prefix
          (etypecase prefix
            (string prefix)
            (symbol (symbol-name prefix)))))
    (labels ((var-p (v)
               "A variable is a symbol that starts with PREFIX"
               (and (symbolp v)
                    (<= (length prefix) (length (symbol-name v)))
                    (string= prefix (symbol-name v) :end2 (length prefix))))
             (pipe-form-p (form)
               "A pipe form is either a symbol or a tree that contains
                exactly one substitution variable, appearing one or more times."
               (or (symbolp form)
                   (let* ((vars
                            (remove-if-not #'var-p (flatten form)))
                          (vars-len
                            (length vars)))
                     ;; either a symbol 
                     (and (<= 1 vars-len)
                          ;; which all must be the same
                          (loop :for x :in (rest vars) :always (eql x (first vars)))))))
             (escape-early-transform (forms)
               "Tramsform the pipe forms to accomodate escape early checks."
               (cond ((null forms) nil)
                     ((and (eql :? (first forms))
                           (second forms)
                           (symbolp (second forms)))
                      (cons `(if (funcall ',(second forms) ,(intern prefix))
                                 ,(intern prefix) (return-from ,block ,fail))
                            (escape-early-transform (cddr forms))))
                     ((and (eql :? (first forms))
                           (listp (second forms)))
                      (let* ((form (second forms))
                             (var (find-if #'var-p (flatten form))))
                        (cons `(if ,form ,var (return-from ,block ,fail))
                              (escape-early-transform (cddr forms)))))
                     (t
                      (cons (first forms)
                            (escape-early-transform (rest forms))))))
             (folder (expansion form)
               "Expand the pipe forms."
               (etypecase form
                 (symbol `(funcall (function ,form) ,expansion))
                 (cons
                  (if (< 1 (count-if #'var-p (flatten form)))
                      (let ((tmp (gensym "VAR-")))
                        `(let ((,tmp ,expansion)) 
                           ,(subst-if tmp #'var-p form)))
                      (subst-if expansion #'var-p form))))))
      (assert (every #'pipe-form-p pipe-forms)
              ()
              "Invalid pipe form: ~s"
              (find-if-not #'pipe-form-p pipe-forms))
      (assert (loop :for (f1 f2) :on pipe-forms
                    :always (or (not (eql :? f1)) (and f2 (not (eql :? f2)))))
              ()
              "Failure checks :? must always be followed by a valid form.")

      (list 'block block
            (reduce #'folder (escape-early-transform pipe-forms) :initial-value initform)))))


(defmacro >>> (initform &rest pipe-forms)
  `(>> () ,initform ,@pipe-forms))

(defmacro ?>> (initform &rest pipe-forms)
  `(>> () ,initform ,@(loop :for form :in pipe-forms
                            :collect :? :collect 'cl:identity
                            :collect form)))

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